home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE22 / XPROCS / XPROCS.ZIP / xProcs.pas
Encoding:
Pascal/Delphi Source File  |  1997-01-19  |  72.7 KB  |  2,792 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       xTool - Component Collection                    }
  4. {                                                       }
  5. {       Copyright (c) 1995 Stefan B÷ther                }
  6. {                            stefc@fabula.com           }
  7. {*******************************************************}
  8. {
  9.   Please look also for our xTools-Nails function toolkit.
  10.   You'll find more information at
  11.      http://ourworld.compuserve.com/homepages/stefc/xprocs.htm
  12.  
  13.   Any comments and suggestions are welcome; please send to:
  14.      stefc@fabula.com.
  15.  
  16.    21.02.96  added TMonth & TDay type                                Stefc
  17.    22.02.96  added strFileLoad & strFileSave                         Stefc
  18.    09.03.96  correct sysTempPath                                     Stefc
  19.    09.03.96  added regXXXXX functions for access the registry        Stefc
  20.    24.03.96  added IsWinNT constant                                  Stefc
  21.    24.03.96  added SysMetric object                                  Stefc
  22.    26.03.96  added dateQuicken for controling date input with keys   Stefc
  23.    27.03.96  added TDesktopCanvas here                               Stefc
  24.    28.03.96  added LoadDIBitmap                                      Stefc
  25.    01.04.96  added Question function here                            Stefc
  26.    09.04.96  added sysSaverRunning added                             Stefc
  27.    12.04.96  added timeZoneOffset                                    Stefc
  28.    12.04.96  added timeToInt                                         Stefc
  29.    17.04.96  added strCmdLine                                        Stefc
  30.    17.04.96  added rectBounds                                        Stefc
  31.    17.04.96  added TPersistentRect class                             Stefc
  32.    19.04.96  added strDebug method                                   Stefc
  33.    21.04.96  changed TMonth added noneMonth                          km
  34.    21.04.96  added licence callback                                  Stefc
  35.    21.04.96  added strNiceDateDefault                                km
  36.    21.04.96  added simple strEncrpyt & strDecrypt                    Stefc
  37.    24.04.96  backport to 16 bit                                      Stefc
  38.    24.04.96  added Information method                                Stefc
  39.    24.04.96  use win messageBox with Win95 in Question & Information Stefc
  40.    09.05.96  new function ExtractName                                Stefc
  41.    10.05.96  Added TPersistentRegistry                               Stefc
  42.    12.05.96  fileExec                                                Stefc
  43.    14.05.96  New function Confirmation                               Stefc
  44.    16.05.96  New function strChange                                  Stefc
  45.    29.05.96  New functions comXXXXX                                  Stefc
  46.    09.06.96  New function strSearchReplace                           km
  47.    09.06.96  ported assembler strHash to plain pascal                Stefc
  48.    15.06.96  new variables xLanguage & xLangOfs                      Stefc
  49.    28.06.96  new method sysBeep                                      Stefc
  50.    28.06.96  new method intPercent                                   Stefc
  51.    10.07.96  make compatible with 16 Bit Delphi 1.0                  Stefc
  52.    14.07.96  fileLongName & fileShortName defined                    Stefc
  53.    15.07.96  Correct sysTempPath method                              Stefc
  54.    21.07.96  New functions strContains & strContainsU                Stefc
  55.    28.07.96  comIsCServe also check for xxx@compuServe.com           Stefc
  56.    31.07.96  added strCapitalize after idea from Fred N. Read        Stefc
  57.    04.08.96  strByteSize() now can also display Bytes                Stefc
  58.    05.08.96  added regWriteShellExt()                                Stefc
  59.    06.08.96  added sysColorDepth()                                   Stefc
  60.    07.08.96  added strSoundex()                                      Stefc
  61.    09.08.96  fixe some bugs in fileShellXXXX                         Stefc
  62.    26.08.96  Added registry functions from David W. Yutzy            Stefc
  63.    29.08.96  fileShellXXX now also aviable under 16 Bit              Stefc
  64.    05.09.96  Added regDelValue                                       Stefc
  65.    13.09.96  Added fltNegativ and fltPositiv                         Stefc
  66.    29.09.96  Added strTokenToStrings & strTokenFromStrings           Stefc
  67.    09.10.96  Added variant function                                  Stefc
  68.    29.10.96  intPrime now can be used for negative numbers           Stefc
  69.    29.10.96  fltEqualZero now returns true with FLTZERO              Stefc
  70.    29.10.96  fltCalc now use Float for greater precision             Stefc
  71.    29.10.96  correct strTokenCount                                   Stefc
  72.    19.11.96  better Windows NT detecting                             Stefc
  73.    28.11.96  correct above text (thanks to Clay Kollenborn-Shannon)  Stefc
  74.    12.01.96  added fileCopy function                                 Stefc
  75.    13.01.96  correct strProfile now it works also for 16-Bit         Stefc
  76.    13.01.96  get English Quicken keys from George Boomer             Stefc
  77.    14.01.96  make key in dateQuicken var to reset if on date change  Stefc
  78.    17.01.96  New functions strPos and strChangeU                     Stefc
  79.    19.01.96  new function fileTypeName after idea of P.Aschenbacher  Stefc
  80.    19.01.96  new function fileRedirectExec                           Stefc
  81.  
  82. }
  83. unit xProcs;
  84.  
  85. {$D-}
  86.  
  87. interface
  88.  
  89. {.$DEFINE German}
  90. {.$DEFINE English}
  91.  
  92. uses
  93.  {$IFDEF Win32} Windows, Registry, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  94.   ShellAPI, Messages, Classes, Graphics;
  95.  
  96. type
  97.   Float = Extended;    { our type for float arithmetic }
  98.  
  99.  {$IFDEF Win32}        { our type for integer functions, Int_ is ever 32 bit }
  100.   Int_  = Integer;
  101.  {$ELSE}
  102.   Int_  = Longint;
  103.  {$ENDIF}
  104.  
  105. const
  106.   XCOMPANY        = 'Fabula Software';
  107.  
  108. const
  109.   { several important ASCII codes }
  110.   NULL            =  #0;
  111.   BACKSPACE       =  #8;
  112.   TAB             =  #9;
  113.   LF              = #10;
  114.   CR              = #13;
  115.   EOF_            = #26;    { 30.07.96 sb }
  116.   ESC             = #27;
  117.   BLANK           = #32;
  118.   SPACE           = BLANK;
  119.  
  120.   { digits as chars }
  121.   ZERO   = '0';  ONE  = '1';  TWO    = '2';  THREE  = '3';  FOUR  = '4';
  122.   FIVE   = '5';  SIX  = '6';  SEVEN  = '7';  EIGHT  = '8';  NINE  = '9';
  123.  
  124.   { special codes }
  125.   SLASH           = '\';     { used in filenames }
  126.   HEX_PREFIX      = '$';     { prefix for hexnumbers }
  127.  
  128.   CRLF            : PChar = CR+LF;
  129.  
  130.   { common computer sizes }
  131.   KBYTE           = Sizeof(Byte) shl 10;
  132.   MBYTE           = KBYTE        shl 10;
  133.   GBYTE           = MBYTE        shl 10;
  134.  
  135.   { Low floating point value }
  136.   FLTZERO         : Float = 0.00000001;
  137.  
  138.   DIGITS          : set of Char = [ZERO..NINE];
  139.  
  140.   { important registry keys / items }
  141.   REG_CURRENT_VERSION = 'Software\Microsoft\Windows\CurrentVersion';
  142.   REG_CURRENT_USER    = 'RegisteredOwner';
  143.   REG_CURRENT_COMPANY = 'RegisteredOrganization';
  144.  
  145.   PRIME_16       = 65521;
  146.   PRIME_32       = 2147483647;
  147.  
  148.   MINSHORTINT    = -128;               { 1.8.96 sb }
  149.   MAXSHORTINT    =  127;
  150.   MINBYTE        =  0;
  151.   MAXBYTE        =  255;
  152.   MINWORD        =  0;
  153.   MAXWORD        =  65535;
  154.  
  155. type
  156.   TMonth        = (NoneMonth,January,February,March,April,May,June,July,
  157.                    August,September,October,November,December);
  158.  
  159.   TDayOfWeek    = (Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday);
  160.  
  161.   { Online eMail Service Provider }
  162.   TMailProvider = (mpCServe, mpInternet, mpNone);
  163.  
  164.   TLicCallback  = function ( var Code: Integer): Integer;
  165.  
  166.   TBit          = 0..31;
  167.  
  168.   { Search and Replace options }
  169.   TSROption     = (srWord,srCase,srAll);
  170.   TSROptions    = set of TsrOption;
  171.  
  172.   { Data types }
  173.   TDataType     = (dtInteger,dtBoolean,dtString,dtDate,dtTime,
  174.                    dtFloat,dtCurrency);
  175.  
  176. var
  177.   IsWin95,
  178.   IsWinNT   : Boolean;
  179.   IsFabula  : TLicCallBack;
  180.  
  181.   xLanguage : Integer;
  182.   xLangOfs  : Integer;
  183.  
  184. { bit manipulating }
  185. function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
  186. function bitOn(const Value: Int_; const TheBit: TBit): Int_;
  187. function bitOff(const Value: Int_; const TheBit: TBit): Int_;
  188. function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
  189.  
  190. { String functions }
  191. function  strHash(const S: String; LastBucket: Integer): Integer;
  192. function  strCut(const S: String; Len: Integer): String;
  193. function  strTrim(const S: String): String;
  194. function  strTrimA(const S: String): String;
  195. function  strTrimChA(const S: String; C: Char): String;
  196. function  strTrimChL(const S: String; C: Char): String;
  197. function  strTrimChR(const S: String; C: Char): String;
  198. function  strLeft(const S: String; Len: Integer): String;
  199. function  strLower(const S: String): String;
  200. function  strMake(C: Char; Len: Integer): String;
  201. function  strPadChL(const S: String; C: Char; Len: Integer): String;
  202. function  strPadChR(const S: String; C: Char; Len: Integer): String;
  203. function  strPadChC(const S: String; C: Char; Len: Integer): String;
  204. function  strPadL(const S: String; Len: Integer): String;
  205. function  strPadR(const S: String; Len: Integer): String;
  206. function  strPadC(const S: String; Len: Integer): String;
  207. function  strPadZeroL(const S: String; Len: Integer): String;
  208. function  strPos(const aSubstr,S: String; aOfs: Integer): Integer;
  209. procedure strChange(var S:String; const Src, Dest: String);
  210. function  strChangeU(const S,Source, Dest: String): String;
  211. function  strRight(const S: String; Len: Integer): String;
  212. function  strAddSlash(const S: String): String;
  213. function  strDelSlash(const S: String): String;
  214. function  strSpace(Len: Integer): String;
  215. function  strToken(var S: String; Seperator: Char): String;
  216. function  strTokenCount(S: String; Seperator: Char): Integer;
  217. function  strTokenAt(const S:String; Seperator: Char; At: Integer): String;
  218. procedure strTokenToStrings(S: String; Seperator: Char; List: TStrings);
  219. function  strTokenFromStrings(Seperator: Char; List: TStrings): String;
  220.  
  221. function  strUpper(const S: String): String;
  222. function  strOemAnsi(const S:String): String;
  223. function  strAnsiOem(const S:String): String;
  224. function  strEqual(const S1,S2: String): Boolean;
  225. function  strComp(const S1,S2: String): Boolean;
  226. function  strCompU(const S1,S2: String): Boolean;
  227. function  strContains(const S1,S2: String): Boolean;
  228. function  strContainsU(const S1,S2: String): Boolean;
  229. function  strNiceNum(const S: String): String;
  230. function  strNiceDateDefault(const S, Default: String): String;
  231. function  strNiceDate(const S: String): String;
  232. function  strNiceTime(const S: String): String;
  233. function  strNicePhone(const S: String): String;
  234. function  strReplace(const S: String; C: Char; const Replace: String): String;
  235. function  strCmdLine: String;
  236. function  strEncrypt(const S: String; Key: Word): String;
  237. function  strDecrypt(const S: String; Key: Word): String;
  238. function  strLastCh(const S: String): Char;
  239. procedure strStripLast(var S: String);
  240. function  strByteSize(Value: Longint): String;
  241. function  strSoundex(S: String): String;
  242. procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
  243. function  strProfile(const aFile, aSection, aEntry, aDefault: String): String;
  244. function  strCapitalize(const S: String): String;  { 31.07.96 sb }
  245.  
  246. {$IFDEF Win32}
  247. procedure strDebug(const S: String);
  248. function  strFileLoad(const aFile: String): String;
  249. procedure strFileSave(const aFile,aString: String);
  250. {$ENDIF}
  251.  
  252. { Integer functions }
  253. function  intCenter(a,b: Int_): Int_;
  254. function  intMax(a,b: Int_): Int_;
  255. function  intMin(a,b: Int_): Int_;
  256. function  intPow(Base,Expo: Integer): Int_;
  257. function  intPow10(Exponent: Integer): Int_;
  258. function  intSign(a: Int_): Integer;
  259. function  intZero(a: Int_; Len: Integer): String;
  260. function  intPrime(Value: Integer): Boolean;
  261. function  intPercent(a, b: Int_): Int_;
  262.  
  263. { Floatingpoint functions }
  264. function  fltAdd(P1,P2: Float; Decimals: Integer): Float;
  265. function  fltDiv(P1,P2: Float; Decimals: Integer): Float;
  266. function  fltEqual(P1,P2: Float; Decimals: Integer): Boolean;
  267. function  fltEqualZero(P: Float): Boolean;
  268. function  fltGreaterZero(P: Float): Boolean;
  269. function  fltLessZero(P: Float): Boolean;
  270. function  fltNeg(P: Float; Negate: Boolean): Float;
  271. function  fltMul(P1,P2: Float; Decimals: Integer): Float;
  272. function  fltRound(P: Float; Decimals: Integer): Float;
  273. function  fltSub(P1,P2: Float; Decimals: Integer): Float;
  274. function  fltUnEqualZero(P: Float): Boolean;
  275. function  fltCalc(const Expr: String): Float;
  276. function  fltPower(a,n: Float): Float;
  277. function  fltPositiv(Value: Float): Float;
  278. function  fltNegativ(Value: Float): Float;
  279.  
  280. { Rectangle functions from Golden Software }
  281. function  rectHeight(const R: TRect): Integer;
  282. function  rectWidth(const R: TRect): Integer;
  283. procedure rectGrow(var R: TRect; Delta: Integer);
  284. procedure rectRelativeMove(var R: TRect; DX, DY: Integer);
  285. procedure rectMoveTo(var R: TRect; X, Y: Integer);
  286. function  rectSet(Left, Top, Right, Bottom: Integer): TRect;
  287. function  rectInclude(const R1, R2: TRect): Boolean;
  288. function  rectPoint(const R: TRect; P: TPoint): Boolean;
  289. function  rectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
  290. function  rectIntersection(const R1, R2: TRect): TRect;
  291. function  rectIsIntersection(const R1, R2: TRect): Boolean;
  292. function  rectIsValid(const R: TRect): Boolean;
  293. function  rectsAreValid(const Arr: array of TRect): Boolean;
  294. function  rectNull: TRect;
  295. function  rectIsNull(const R: TRect): Boolean;
  296. function  rectIsSquare(const R: TRect): Boolean;
  297. function  rectCentralPoint(const R: TRect): TPoint;
  298. function  rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;
  299.  
  300. {$IFDEF Win32}
  301. { Variant functions }
  302. function  varIIF( aTest: Boolean; TrueValue, FalseValue : Variant): Variant;
  303. procedure varDebug(const V: Variant);
  304. function  varToStr(const V: Variant): String;
  305. {$ENDIF}
  306.  
  307. { date functions }
  308. function  dateYear(D: TDateTime): Integer;
  309. function  dateMonth(D: TDateTime): Integer;
  310. function  dateDay(D: TDateTime): Integer;
  311. function  dateBeginOfYear(D: TDateTime): TDateTime;
  312. function  dateEndOfYear(D: TDateTime): TDateTime;
  313. function  dateBeginOfMonth(D: TDateTime): TDateTime;
  314. function  dateEndOfMonth(D: TDateTime): TDateTime;
  315. function  dateWeekOfYear(D: TDateTime): Integer;
  316. function  dateDayOfYear(D: TDateTime): Integer;
  317. function  dateDayOfWeek(D: TDateTime): TDayOfWeek;
  318. function  dateLeapYear(D: TDateTime): Boolean;
  319. function  dateBeginOfQuarter(D: TDateTime): TDateTime;
  320. function  dateEndOfQuarter(D: TDateTime): TDateTime;
  321. function  dateBeginOfWeek(D: TDateTime;Weekday: Integer): TDateTime;
  322. function  dateDaysInMonth(D: TDateTime): Integer;
  323. function  dateQuicken(D: TDateTime; var Key: Char): TDateTime;
  324. {function  dateDiff(D1,D2: TDateTime): Integer;}
  325.  
  326. { time functions }
  327. function  timeHour(T: TDateTime): Integer;
  328. function  timeMin(T: TDateTime): Integer;
  329. function  timeSec(T: TDateTime): Integer;
  330. function  timeToInt(T: TDateTime): Integer;
  331.  
  332. {$IFDEF Win32}
  333. function  timeZoneOffset: Integer;
  334. {$ENDIF}
  335.  
  336. { com Functions }
  337. function  comIsCis(const S: String): Boolean;
  338. function  comIsInt(const S: String): Boolean;
  339. function  comCisToInt(const S: String): String;
  340. function  comIntToCis(const S: String): String;
  341. function  comFaxToCis(const S: String): String;
  342. function  comNormFax(const Name,Fax: String): String;
  343. function  comNormPhone(const Phone: String): String;
  344. function  comNormInt(const Name,Int: String): String;
  345. function  comNormCis(const Name,Cis: String): String;
  346.  
  347. { file functions }
  348. procedure fileShredder(const Filename: String);
  349. function  fileSize(const Filename: String): Longint;
  350. function  fileWildcard(const Filename: String): Boolean;
  351. function  fileShellOpen(const aFile: String): Boolean;
  352. function  fileShellPrint(const aFile: String): Boolean;
  353. function  fileCopy(const SourceFile, TargetFile: String): Boolean;
  354.  
  355. {$IFDEF Win32}
  356. function  fileTemp(const aExt: String): String;
  357. function  fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
  358. function  fileRedirectExec(const aCmdLine: String; Strings: TStrings): Boolean;
  359. function  fileLongName(const aFile: String): String;
  360. function  fileShortName(const aFile: String): String;
  361. function  fileTypeName(const aFile: String): String;
  362. {$ENDIF}
  363. function  ExtractName(const Filename: String): String;
  364.  
  365. { system functions }
  366. function  sysTempPath:String;
  367. procedure sysDelay(aMs: Longint);
  368. procedure sysBeep;
  369. function  sysColorDepth: Integer;    { 06.08.96 sb }
  370.  
  371. {$IFDEF Win32}
  372. procedure sysSaverRunning(Active: Boolean);
  373. {$ENDIF}
  374.  
  375. { registry functions }
  376.  
  377. {$IFDEF Win32}
  378. function  regReadString(aKey: hKey; const Path: String): String;
  379. procedure regWriteString(aKey: hKey; const Path,Value: String);
  380. procedure regDelValue(aKey: hKey; const Path: String);
  381. function  regInfoString(const Value: String): String;
  382. function  regCurrentUser: String;
  383. function  regCurrentCompany: String;
  384. procedure regWriteShellExt(const aExt,aCmd,aMenu,aExec: String);
  385.  
  386. { The following five functions came from David W. Yutzy / Celeste Software Services
  387.   Thanks for submitting us the methods !!
  388. }
  389. procedure regKeyList(aKey: HKEY; const Path:String; var aValue: TStringList);
  390. function  regValueExist(aKey: HKEY; const Path:String):Boolean;
  391. function  regWriteValue(aKey: HKEY; const Path: String; Value: Variant; Typ: TDataType): Boolean;
  392. function  regReadValue(aKey:HKEY; const Path:String; Typ: TDataType): Variant;
  393. procedure regValueList(aKey: HKEY; const Path:String; var aValue: TStringList);
  394. {$ENDIF}
  395.  
  396. { several functions }
  397. function  Question(const Msg: String):Boolean;
  398. procedure Information(const Msg: String);
  399. function  Confirmation(const Msg: String): Word;
  400.  
  401. type
  402.   { TRect that can be used persistent as property for components }
  403.   TUnitConvertEvent = function (Sender: TObject;
  404.     Value: Integer; Get: Boolean): Integer of object;
  405.  
  406.   TPersistentRect = class(TPersistent)
  407.   private
  408.     FRect      : TRect;
  409.     FOnConvert : TUnitConvertEvent;
  410.     procedure SetLeft(Value: Integer);
  411.     procedure SetTop(Value: Integer);
  412.     procedure SetHeight(Value: Integer);
  413.     procedure SetWidth(Value: Integer);
  414.     function  GetLeft: Integer;
  415.     function  GetTop: Integer;
  416.     function  GetHeight: Integer;
  417.     function  GetWidth: Integer;
  418.   public
  419.     constructor Create;
  420.     procedure Assign(Source: TPersistent); override;
  421.     property Rect: TRect read FRect;
  422.     property OnConvert: TUnitConvertEvent read FOnConvert write FOnConvert;
  423.   published
  424.     property Left  : Integer read GetLeft   write SetLeft;
  425.     property Top   : Integer read GetTop    write SetTop;
  426.     property Height: Integer read GetHeight write SetHeight;
  427.     property Width : Integer read GetWidth  write SetWidth;
  428.   end;
  429.  
  430. {$IFDEF Win32}
  431.   { Persistent access of components from the registry }
  432.   TPersistentRegistry = class(TRegistry)
  433.   public
  434.     function  ReadComponent(const Name: String; Owner, Parent: TComponent): TComponent;
  435.     procedure WriteComponent(const Name: String; Component: TComponent);
  436.   end;
  437. {$ENDIF
  438.  
  439.   { easy access of the system metrics }
  440.   TSystemMetric = class
  441.   private
  442.     FColorDepth,
  443.     FMenuHeight,
  444.     FCaptionHeight : Integer;
  445.     FBorder,
  446.     FFrame,
  447.     FDlgFrame,
  448.     FBitmap,
  449.     FHScroll,
  450.     FVScroll,
  451.     FThumb,
  452.     FFullScreen,
  453.     FMin,
  454.     FMinTrack,
  455.     FCursor,
  456.     FIcon,
  457.     FDoubleClick,
  458.     FIconSpacing : TPoint;
  459.   protected
  460.     constructor Create;
  461.     procedure Update;
  462.   public
  463.     property MenuHeight: Integer read FMenuHeight;
  464.     property CaptionHeight: Integer read FCaptionHeight;
  465.     property Border: TPoint read FBorder;
  466.     property Frame: TPoint read FFrame;
  467.     property DlgFrame: TPoint read FDlgFrame;
  468.     property Bitmap: TPoint read FBitmap;
  469.     property HScroll: TPoint read FHScroll;
  470.     property VScroll: TPoint read FVScroll;
  471.     property Thumb: TPoint read FThumb;
  472.     property FullScreen: TPoint read FFullScreen;
  473.     property Min: TPoint read FMin;
  474.     property MinTrack: TPoint read FMinTrack;
  475.     property Cursor: TPoint read FCursor;
  476.     property Icon: TPoint read FIcon;
  477.     property DoubleClick: TPoint read FDoubleClick;
  478.     property IconSpacing: TPoint read FIconSpacing;
  479.     property ColorDepth: Integer read FColorDepth;
  480.   end;
  481.  
  482. var
  483.   SysMetric: TSystemMetric;
  484.  
  485. type
  486.   TDesktopCanvas = class(TCanvas)
  487.   private
  488.     DC           : hDC;
  489.   public
  490.     constructor  Create;
  491.     destructor   Destroy; override;
  492.   end;
  493.  
  494. implementation
  495.  
  496. uses
  497.   SysUtils, Controls, Forms, Consts, Dialogs;
  498.  
  499. { bit manipulating }
  500. function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
  501. begin
  502.   Result:= (Value and (1 shl TheBit)) <> 0;
  503. end;
  504.  
  505. function bitOn(const Value: Int_; const TheBit: TBit): Int_;
  506. begin
  507.   Result := Value or (1 shl TheBit);
  508. end;
  509.  
  510. function bitOff(const Value: Int_; const TheBit: TBit): Int_;
  511. begin
  512.   Result := Value and ((1 shl TheBit) xor $FFFFFFFF);
  513. end;
  514.  
  515. function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
  516. begin
  517.   result := Value xor (1 shl TheBit);
  518. end;
  519.  
  520. { string methods }
  521.  
  522. function strHash(const S: String; LastBucket: Integer): Integer;
  523. var
  524.   i: Integer;
  525. begin
  526.   Result:=0;
  527.   for i := 1 to Length(S) do
  528.     Result := ((Result shl 3) xor Ord(S[i])) mod LastBucket;
  529. end;
  530.  
  531. function strTrim(const S: String): String;
  532. begin
  533.   Result:=StrTrimChR(StrTrimChL(S,BLANK),BLANK);
  534. end;
  535.  
  536. function strTrimA(const S: String): String;
  537. begin
  538.   Result:=StrTrimChA(S,BLANK);
  539. end;
  540.  
  541. function strTrimChA(const S: String; C: Char): String;
  542. var
  543.   I               : Word;
  544. begin
  545.   Result:=S;
  546.   for I:=Length(Result) downto 1 do
  547.     if Result[I]=C then Delete(Result,I,1);
  548. end;
  549.  
  550. function strTrimChL(const S: String; C: Char): String;
  551. begin
  552.   Result:=S;
  553.   while (Length(Result)>0) and (Result[1]=C) do Delete(Result,1,1);
  554. end;
  555.  
  556. function strTrimChR(const S: String; C: Char): String;
  557. begin
  558.   Result:=S;
  559.   while (Length(Result)> 0) and (Result[Length(Result)]=C) do
  560.     Delete(Result,Length(Result),1);
  561. end;
  562.  
  563. function strLeft(const S: String; Len: Integer): String;
  564. begin
  565.   Result:=Copy(S,1,Len);
  566. end;
  567.  
  568. function strLower(const S: String): String;
  569. begin
  570.   Result:=AnsiLowerCase(S);
  571. end;
  572.  
  573. function strMake(C: Char; Len: Integer): String;
  574. begin
  575.   Result:=strPadChL('',C,Len);
  576. end;
  577.  
  578. function strPadChL(const S: String; C: Char; Len: Integer): String;
  579. begin
  580.   Result:=S;
  581.   while Length(Result)<Len do Result:=C+Result;
  582. end;
  583.  
  584. function strPadChR(const S: String; C: Char; Len: Integer): String;
  585. begin
  586.   Result:=S;
  587.   while Length(Result)<Len do Result:=Result+C;
  588. end;
  589.  
  590. function strPadChC(const S: String; C: Char; Len: Integer): String;
  591. begin
  592.   Result:=S;
  593.   while Length(Result)<Len do
  594.   begin
  595.     Result:=Result+C;
  596.     if Length(Result)<Len then Result:=C+Result;
  597.   end;
  598. end;
  599.  
  600. function strPadL(const S: String; Len: Integer): String;
  601. begin
  602.   Result:=strPadChL(S,BLANK,Len);
  603. end;
  604.  
  605. function strPadC(const S: String; Len: Integer): String;
  606. begin
  607.   Result:=strPadChC(S,BLANK,Len);
  608. end;
  609.  
  610.  
  611. function strPadR(const S: String; Len: Integer): String;
  612. begin
  613.   Result:=strPadChR(S,BLANK,Len);
  614. end;
  615.  
  616. function strPadZeroL(const S: String; Len: Integer): String;
  617. begin
  618.   Result:=strPadChL(strTrim(S),ZERO,Len);
  619. end;
  620.  
  621. function strCut(const S: String; Len: Integer): String;
  622. begin
  623.   Result:=strLeft(strPadR(S,Len),Len);
  624. end;
  625.  
  626. function strRight(const S: String; Len: Integer): String;
  627. begin
  628.   if Len>=Length(S) then
  629.     Result:=S
  630.   else
  631.     Result:=Copy(S,Succ(Length(S))-Len,Len);
  632. end;
  633.  
  634. function strAddSlash(const S: String): String;
  635. begin
  636.   Result:=S;
  637.   if strLastCh(Result)<>SLASH then Result:=Result+SLASH;
  638. end;
  639.  
  640. function strDelSlash(const S: String): String;
  641. begin
  642.   Result:=S;
  643.   if strLastCh(Result)=SLASH then Delete(Result,Length(Result),1);
  644. end;
  645.  
  646. function strSpace(Len: Integer): String;
  647. begin
  648.   Result:=StrMake(BLANK,Len);
  649. end;
  650.  
  651. function strToken(var S: String; Seperator: Char): String;
  652. var
  653.   I               : Word;
  654. begin
  655.   I:=Pos(Seperator,S);
  656.   if I<>0 then
  657.   begin
  658.     Result:=System.Copy(S,1,I-1);
  659.     System.Delete(S,1,I);
  660.   end else
  661.   begin
  662.     Result:=S;
  663.     S:='';
  664.   end;
  665. end;
  666.  
  667. function strTokenCount(S: String; Seperator: Char): Integer;
  668. begin
  669.   Result:=0;
  670.   while S<>'' do begin            { 29.10.96 sb }
  671.     StrToken(S,Seperator);
  672.     Inc(Result);
  673.   end;
  674. end;
  675.  
  676. function strTokenAt(const S:String; Seperator: Char; At: Integer): String;
  677. var
  678.   j,i: Integer;
  679. begin
  680.   Result:='';
  681.   j := 1;
  682.   i := 0;
  683.   while (i<=At ) and (j<=Length(S)) do
  684.   begin
  685.     if S[j]=Seperator then
  686.        Inc(i)
  687.     else if i = At then
  688.        Result:=Result+S[j];
  689.     Inc(j);
  690.   end;
  691. end;
  692.  
  693. procedure strTokenToStrings(S: String; Seperator: Char; List: TStrings);
  694. var
  695.   Token: String;
  696. begin
  697.   List.Clear;
  698.   Token:=strToken(S,Seperator);
  699.   while Token<>'' do
  700.   begin
  701.     List.Add(Token);
  702.     Token:=strToken(S,Seperator);
  703.   end;
  704. end;
  705.  
  706. function strTokenFromStrings(Seperator: Char; List: TStrings): String;
  707. var
  708.   i: Integer;
  709. begin
  710.   Result:='';
  711.   for i:=0 to List.Count-1 do
  712.      if Result<>'' then
  713.        Result:=Result+Seperator+List[i]
  714.      else
  715.        Result:=List[i];
  716. end;
  717.  
  718. function strUpper(const S: String): String;
  719. begin
  720.   Result:=AnsiUpperCase(S);
  721. end;
  722.  
  723. function strOemAnsi(const S:String):String;
  724. begin
  725.  {$IFDEF Win32}
  726.   SetLength(Result,Length(S));
  727.  {$ELSE}
  728.   Result[0]:=Chr(Length(S));
  729.  {$ENDIF}
  730.   OemToAnsiBuff(@S[1],@Result[1],Length(S));
  731. end;
  732.  
  733. function strAnsiOem(const S:String): String;
  734. begin
  735.  {$IFDEF Win32}
  736.   SetLength(Result,Length(S));
  737.  {$ELSE}
  738.   Result[0]:=Chr(Length(S));
  739.  {$ENDIF}
  740.   AnsiToOemBuff(@S[1],@Result[1],Length(S));
  741. end;
  742.  
  743. function strEqual(const S1,S2: String): Boolean;
  744. begin
  745.   Result:=AnsiCompareText(S1,S2)=0;
  746. end;
  747.  
  748. function strCompU(const S1,S2: String) : Boolean;
  749. begin
  750.   Result:=strEqual(strLeft(S2,Length(S1)),S1);
  751. end;
  752.  
  753. function strComp(const S1,S2: String) : Boolean;
  754. begin
  755.   Result:=strLeft(S2,Length(S1))=S1;
  756. end;
  757.  
  758. function strContains(const S1,S2: String): Boolean;
  759. begin
  760.   Result:=Pos(S1,S2) > 0;
  761. end;
  762.  
  763. function strContainsU(const S1,S2: String): Boolean;
  764. begin
  765.   Result:=strContains(strUpper(S1),strUpper(S2));
  766. end;
  767.  
  768. function strNiceNum(const S: String) : String;
  769. var
  770.   i    : Integer;
  771.   Seps : set of Char;
  772. begin
  773.   Seps:=[ThousandSeparator,DecimalSeparator];
  774.   Result:= ZERO;
  775.   for i := 1 to Length(S) do
  776.     if S[i] in DIGITS + Seps then
  777.     begin
  778.       if S[i] = ThousandSeparator then
  779.          Result:=Result+DecimalSeparator
  780.       else
  781.          Result:=Result+S[i];
  782.       if S[i] In Seps then Seps:=[];
  783.     end
  784. end;
  785.  
  786. function strNiceDate(const S: String): String;
  787. begin
  788.   Result:=strNiceDateDefault(S, DateToStr(Date));
  789. end;
  790.  
  791. function  strNiceDateDefault(const S, Default: String): String;
  792. (* sinn der Procedure:
  793.    Irgendeinen String ⁿbergeben und in ein leidlich brauchbares Datum verwandeln.
  794.    Im Wesentlichen zum Abfangen des Kommazeichens auf dem Zehnerfeld.
  795.    eingabe 10 = Rⁿckgabe 10 des Laufenden Monats
  796.    eingabe 10.12 = Rⁿckgabe des 10.12. des laufenden Jahres.
  797.    eingabe 10.12.96 = Rⁿckgabe des Strings
  798.    eingabe 10,12,96 = Rⁿckgabe 10.12.95 (wird dann won STRtoDATE() gefressen)
  799.    Eine PlausbilitΣtskontrolle des Datums findet nicht Statt.
  800.    Geplante Erweiterung:
  801.    eingabe: +14  = Rⁿckgabe 14 Tage Weiter
  802.    eingabe: +3m  = Rⁿckgabe 3 Monate ab Heute
  803.    eingabe: +3w  = Rⁿckgabe 3 Wochen (3*7 Tage) ab Heute
  804.    Das gleiche auch RⁿckwΣrts mit  Minuszeichen
  805.    eingabe: e oder E oder f  = NΣchster Erster
  806.    eingabe: e+1m Erster des ⁿbernΣchsten Monats
  807.    Da lΣ▀t sich aber noch trefflich weiterspinnen
  808.  
  809.    EV. mit Quelle rausgeben, damit sich die EnglΣnder und Franzosen an
  810.    Ihren Datumsformaten selbst erfreuen k÷nnen und wir die passenden umsetzungen
  811.    bekommen. *)
  812. var
  813.   a        : array [0..2] of string[4];
  814.   heute    : string;
  815.   i,j      : integer;
  816. begin
  817.   a[0]:='';
  818.   a[1]:='';
  819.   a[2]:='';
  820.   heute := Default;
  821.  
  822.   j := 0;
  823.   for i := 0 to length(S) do
  824.     if S[i] in DIGITS then
  825.       a[j] := a[j]+S[i]
  826.     else if S[i] in [DateSeparator] then Inc(j);
  827.   for i := 0 to 2 do
  828.   if Length(a[i]) = 0 then
  829.     if I=2 then
  830.       a[i] :=copy(heute,i*3+1,4)
  831.     else
  832.       a[i] := copy(heute,i*3+1,2)
  833.   else
  834.     if length(a[i]) = 1 then
  835.       a[i] := '0'+a[i];
  836.  
  837.   Result:=a[0]+DateSeparator+a[1]+DateSeparator+a[2];
  838.   try
  839.     StrToDate(Result);
  840.   except
  841.     Result:=DateToStr(Date);
  842.   end;
  843. end;
  844.  
  845. function strNiceTime(const S: String): String;
  846. var
  847.   a   : array[0..2] of string[2];
  848.   i,j : integer;
  849. begin
  850.   j:= 0;
  851.   a[0]:= '';
  852.   a[1]:='';
  853.   a[2]:='';
  854.   for i:= 1 to length(S) do
  855.   begin
  856.     if S[i] in DIGITS then
  857.     begin
  858.       a[j] := a[j]+S[i];
  859.     end
  860.     else if S[i] in ['.',',',':'] then
  861.       inc(J);
  862.     if j > 2 then exit;
  863.   end;
  864.   for J := 0 to 2 do
  865.     if length(a[j]) = 1 then a[j] := '0'+a[j] else
  866.     if length(a[j]) = 0 then a[j] := '00';
  867.   Result := a[0]+TimeSeparator+a[1]+TimeSeparator+a[2];
  868. end;
  869.  
  870. function strNicePhone(const S: String): String;
  871. var
  872.   L : Integer;
  873. begin
  874.   if Length(S) > 3 then
  875.   begin
  876.     L:=(Length(S)+1) div 2;
  877.     Result:=strNicePhone(strLeft(S,L))+SPACE+strNicePhone(strRight(S,Length(S)-L));
  878.   end else
  879.     Result := S;
  880. end;
  881.  
  882. function strReplace(const S: String; C: Char; const Replace: String): String;
  883. var
  884.   i : Integer;
  885. begin
  886.   Result:='';
  887.   for i:=Length(S) downto 1 do
  888.     if S[i]=C then Result:=Replace+Result
  889.               else Result:=S[i]+Result;
  890. end;
  891.  
  892. function strPos(const aSubstr,S: String; aOfs: Integer): Integer;
  893. begin
  894.   Result:=Pos(aSubStr,Copy(S,aOfs,(Length(S)-aOfs)+1));
  895.   if (Result>0) and (aOfs>1) then Inc(Result,aOfs-1);
  896. end;
  897.  
  898. procedure strChange(var S:String; const Src, Dest: String);
  899. var
  900.   P : Integer;
  901. begin
  902.   P:=Pos(Src,S);
  903.   while P<>0 do
  904.   begin
  905.     Delete(S,P,Length(Src));
  906.     Insert(Dest,S,P);
  907.     Inc(P,Length(Dest));
  908.     P:=strPos(Src,S,P);
  909.   end;
  910. end;
  911.  
  912. function strChangeU(const S,Source, Dest: String): String;
  913. var
  914.   P    : Integer;
  915.   aSrc : String;
  916. begin
  917.   Result:=S;
  918.   aSrc:=strUpper(Source);
  919.   P:=Pos(aSrc,strUpper(Result));
  920.   while P<>0 do
  921.   begin
  922.     Delete(Result,P,Length(Source));
  923.     Insert(Dest,Result,P);
  924.     Inc(P,Length(Dest));
  925.     P:=strPos(aSrc,strUpper(Result),P);
  926.   end;
  927. end;
  928.  
  929.  
  930. function strCmdLine: String;
  931. var
  932.   i: Integer;
  933. begin
  934.   Result:='';
  935.   for i:=1 to ParamCount do Result:=Result+ParamStr(i)+' ';
  936.   Delete(Result,Length(Result),1);
  937. end;
  938.  
  939. { sends a string to debug windows inside the IDE }
  940. {$IFDEF Win32}
  941. procedure strDebug(const S: String);
  942. var
  943.   P    : PChar;
  944.   CPS  : TCopyDataStruct;
  945.   aWnd : hWnd;
  946. begin
  947.   aWnd := FindWindow('TfrmDbgTerm', nil);
  948.   if aWnd <> 0 then
  949.   begin
  950.     CPS.cbData := Length(S) + 2;
  951.     GetMem(P, CPS.cbData);
  952.     try
  953.       StrPCopy(P, S+CR);
  954.       CPS.lpData := P;
  955.       SendMessage(aWnd, WM_COPYDATA, 0, LParam(@CPS));
  956.     finally
  957.       FreeMem(P, Length(S)+2);
  958.     end;
  959.   end;
  960. end;
  961. {$ENDIF}
  962.  
  963. function strSoundex(S: String): String;
  964. const
  965.   CvTable : array['B'..'Z'] of char = (
  966.     '1', '2', '3', '0', '1',   {'B' .. 'F'}
  967.     '2', '0', '0', '2', '2',   {'G' .. 'K'}
  968.     '4', '5', '5', '0', '1',   {'L' .. 'P'}
  969.     '2', '6', '2', '3', '0',   {'Q' .. 'U'}
  970.     '1', '0', '2', '0', '2' ); {'V' .. 'Z'}
  971. var
  972.   i,j : Integer;
  973.   aGroup,Ch  : Char;
  974.  
  975.   function Group(Ch: Char): Char;
  976.   begin
  977.     if (Ch in ['B' .. 'Z']) and not (Ch In ['E','H','I','O','U','W','Y']) then
  978.        Result:=CvTable[Ch]
  979.     else
  980.        Result:='0';
  981.   end;
  982.  
  983. begin
  984.   Result := '000';
  985.   if S='' then exit;
  986.  
  987.   S:= strUpper(S);
  988.   i:= 2;
  989.   j:= 1;
  990.   while (i <= Length(S)) and ( j<=3) do
  991.   begin
  992.     Ch := S[i];
  993.     aGroup := Group(Ch);
  994.     if (aGroup <> '0') and (Ch <> S[i-1]) and
  995.        ((J=1) or (aGroup <> Result[j-1])) and
  996.        ((i>2) or (aGroup <> Group(S[1]))) then
  997.     begin
  998.       Result[j] :=aGroup;
  999.       Inc(j);
  1000.     end;
  1001.     Inc(i);
  1002.   end; {while}
  1003.  
  1004.   Result:=S[1]+'-'+Result;
  1005. end;
  1006.  
  1007. function strByteSize(Value: Longint): String;
  1008.  
  1009.   function FltToStr(F: Extended): String;
  1010.   begin
  1011.     Result:=FloatToStrF(Round(F),ffNumber,6,0);
  1012.   end;
  1013.  
  1014. begin
  1015.   if Value > GBYTE then
  1016.     Result:=FltTostr(Value / GBYTE)+' GB'
  1017.   else if Value > MBYTE then
  1018.     Result:=FltToStr(Value / MBYTE)+' MB'
  1019.   else if Value > KBYTE then
  1020.     Result:=FltTostr(Value / KBYTE)+' KB'
  1021.   else
  1022.     Result:=FltTostr(Value) +' Byte';   { 04.08.96 sb }
  1023. end;
  1024.  
  1025. const
  1026.   C1 = 52845;
  1027.   C2 = 22719;
  1028.  
  1029. function strEncrypt(const S: String; Key: Word): String;
  1030. var
  1031.   I: Integer;
  1032. begin
  1033.  {$IFDEF Win32}
  1034.   SetLength(Result,Length(S));
  1035.  {$ELSE}
  1036.    Result[0]:=Chr(Length(S));
  1037.  {$ENDIF}
  1038.   for I := 1 to Length(S) do begin
  1039.     Result[I] := Char(Ord(S[I]) xor (Key shr 8));
  1040.     Key := (Ord(Result[I]) + Key) * C1 + C2;
  1041.   end;
  1042. end;
  1043.  
  1044. function strDecrypt(const S: String; Key: Word): String;
  1045. var
  1046.   I: Integer;
  1047. begin
  1048.  {$IFDEF Win32}
  1049.   SetLength(Result,Length(S));
  1050.  {$ELSE}
  1051.    Result[0]:=Chr(Length(S));
  1052.  {$ENDIF}
  1053.   for I := 1 to Length(S) do begin
  1054.     Result[I] := char(Ord(S[I]) xor (Key shr 8));
  1055.     Key := (Ord(S[I]) + Key) * C1 + C2;
  1056.   end;
  1057. end;
  1058.  
  1059. function  strLastCh(const S: String): Char;
  1060. begin
  1061.   Result:=S[Length(S)];
  1062. end;
  1063.  
  1064. procedure strStripLast(var S: String);
  1065. begin
  1066.   if Length(S) > 0 then Delete(S,Length(S),1);
  1067. end;
  1068.  
  1069. procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
  1070. var hs,hs1,hs2,hs3: String;
  1071. var i,j : integer;
  1072.  
  1073. begin
  1074.  if  srCase in Options then
  1075.   begin
  1076.    hs := s;
  1077.    hs3 := source;
  1078.   end
  1079.  else
  1080.   begin
  1081.    hs:= StrUpper(s);
  1082.    hs3 := StrUpper(Source);
  1083.   end;
  1084.  hs1:= '';
  1085.  I:= pos(hs3,hs);
  1086.  j := length(hs3);
  1087.  while i > 0 do
  1088.  begin
  1089.    delete(hs,1,i+j-1); {Anfang Rest geΣndert 8.7.96 KM}
  1090.    hs1 := Hs1+copy(s,1,i-1); {Kopieren geΣndert 8.7.96 KM}
  1091.    delete(s,1,i-1); {L÷schen bis Anfang posgeΣndert 8.7.96 KM}
  1092.    hs2 := copy(s,1,j); {Bis ende pos Sichern}
  1093.    delete(s,1,j); {L÷schen bis ende Pos}
  1094.    if    (not (srWord in Options))
  1095.        or (pos(s[1],' .,:;-#''+*?=)(/&%$º"!{[]}\~<>|') > 0) then
  1096.     begin
  1097.      {Quelle durch ziel erstzen}
  1098.      hs1 := hs1+dest;
  1099.     end
  1100.    else
  1101.     begin
  1102.      hs1 := hs1+hs2;
  1103.     end;
  1104.    if srall in options then
  1105.     I:= pos(hs3,hs)
  1106.    else
  1107.     i :=0;
  1108.   end;
  1109.   s:= hs1+s;
  1110. end;
  1111.  
  1112. function  strProfile(const aFile, aSection, aEntry, aDefault: String): String;
  1113. var
  1114.   aTmp: array[0..255] of Char;
  1115.  {$IFNDEF Win32}
  1116.   pFile    : array[0..200] of char;
  1117.   pSection : array[0..100] of char;
  1118.   pEntry   : array[0..100] of char;
  1119.   pDefault : array[0..100] of char;
  1120.  {$ENDIF}
  1121. begin
  1122.  {$IFDEF Win32}
  1123.    GetPrivateProfileString(PChar(aSection), PChar(aEntry),
  1124.       PChar(aDefault), aTmp, Sizeof(aTmp)-1, PChar(aFile));
  1125.    Result:=StrPas(aTmp);
  1126.  {$ELSE}
  1127.     GetPrivateProfileString(StrPCopy(pSection,aSection),
  1128.       StrPCopy(pEntry,aEntry), StrPCopy(pDefault,aDefault),
  1129.         aTmp, Sizeof(aTmp)-1,  StrPCopy(pFile,aFile));
  1130.     Result:=StrPas(aTmp);
  1131.  {$ENDIF}
  1132. end;
  1133.  
  1134. function strCapitalize(const S: String): String;  { 31.07.96 sb }
  1135. var
  1136.   i      : Integer;
  1137.   Ch     : Char;
  1138.   First  : Boolean;
  1139. begin
  1140.   First  := True;
  1141.   Result := '';
  1142.   for i:=1 to Length(S) do
  1143.   begin
  1144.     Ch:=S[i];
  1145.     if Ch in [SPACE,'-','.'] then
  1146.        First:=True
  1147.     else if First then
  1148.     begin
  1149.       Ch:=strUpper(Ch)[1];
  1150.       First:=False;
  1151.     end;
  1152.     Result:=Result+Ch;
  1153.   end;
  1154. end;
  1155.  
  1156. {$IFDEF Win32}
  1157. function strFileLoad(const aFile: String): String;
  1158. var
  1159.   aStr : TStrings;
  1160. begin
  1161.   Result:='';
  1162.   aStr:=TStringList.Create;
  1163.   try
  1164.     aStr.LoadFromFile(aFile);
  1165.     Result:=aStr.Text;
  1166.   finally
  1167.     aStr.Free;
  1168.   end;
  1169. end;
  1170.  
  1171. procedure strFileSave(const aFile,aString: String);
  1172. var
  1173.   Stream: TStream;
  1174. begin
  1175.   Stream := TFileStream.Create(aFile, fmCreate);
  1176.   try
  1177.     Stream.WriteBuffer(Pointer(aString)^,Length(aString));
  1178.   finally
  1179.     Stream.Free;
  1180.   end;
  1181. end;
  1182. {$ENDIF}
  1183.  
  1184. { Integer stuff }
  1185.  
  1186. function IntCenter(a,b: Int_): Int_;
  1187. begin
  1188.   Result:=a div 2 - b div 2;
  1189. end;
  1190.  
  1191. function IntMax(a,b: Int_): Int_;
  1192. begin
  1193.   if a>b then Result:=a else Result:=b;
  1194. end;
  1195.  
  1196. function IntMin(a,b: Int_): Int_;
  1197. begin
  1198.   if a<b then Result:=a else Result:=b;
  1199. end;
  1200.  
  1201. function IntPow(Base,Expo: Integer): Int_;
  1202. var
  1203.   Loop             : Word;
  1204. begin
  1205.   Result:=1;
  1206.   for Loop:=1 to Expo do Result:=Result*Base;
  1207. end;
  1208.  
  1209. function IntPow10(Exponent: Integer): Int_;
  1210. begin
  1211.   Result:=IntPow(10,Exponent);
  1212. end;
  1213.  
  1214. function IntSign(a: Int_): Integer;
  1215. begin
  1216.   if a<0 then Result:=-1 else if a>0 then Result:=+1 else Result:= 0;
  1217. end;
  1218.  
  1219. function IntZero(a: Int_; Len: Integer): String;
  1220. begin
  1221.   Result:=strPadZeroL(IntToStr(a),Len);
  1222. end;
  1223.  
  1224. function IntPrime(Value: Integer): Boolean;
  1225. var
  1226.   i : integer;
  1227. begin
  1228.   Result:=False;
  1229.   Value:=Abs(Value);                     { 29.10.96 sb }
  1230.   if Value mod 2 <> 0 then
  1231.   begin
  1232.     i := 1;
  1233.     repeat
  1234.       i := i + 2;
  1235.       Result:= Value mod i = 0
  1236.     until Result or ( i > Trunc(sqrt(Value)) );
  1237.     Result:= not Result;
  1238.   end;
  1239. end;
  1240.  
  1241. function IntPercent(a, b : Int_): Int_;
  1242. begin
  1243.   Result := Trunc((a / b)*100);
  1244. end;
  1245.  
  1246. { Floating point stuff }
  1247.  
  1248. function FltAdd(P1,P2: Float; Decimals: Integer): Float;
  1249. begin
  1250.   P1    :=fltRound(P1,Decimals);
  1251.   P2    :=fltRound(P2,Decimals);
  1252.   Result:=fltRound(P1+P2,Decimals);
  1253. end;
  1254.  
  1255. function FltDiv(P1,P2: Float; Decimals: Integer): Float;
  1256. begin
  1257.   P1:=fltRound(P1,Decimals);
  1258.   P2:=fltRound(P2,Decimals);
  1259.   if P2=0.0 then P2:=FLTZERO;       { provide division by zero }
  1260.   Result:=fltRound(P1/P2,Decimals);
  1261. end;
  1262.  
  1263. function FltEqual(P1,P2: Float; Decimals: Integer): Boolean;
  1264. var
  1265.   Diff            : Float;
  1266. begin
  1267.   Diff:=fltSub(P1,P2,Decimals);
  1268.   Result:=fltEqualZero(Diff);
  1269. end;
  1270.  
  1271. function FltEqualZero(P: Float): Boolean;
  1272. begin
  1273.   Result:=(P>=-FLTZERO) and (P<=FLTZERO);          { 29.10.96 sb }
  1274. end;
  1275.  
  1276. function FltGreaterZero(P: Float): Boolean;
  1277. begin
  1278.   Result:=P>FLTZERO;
  1279. end;
  1280.  
  1281. function FltLessZero(P: Float): Boolean;
  1282. begin
  1283.   Result:=P<-FLTZERO;
  1284. end;
  1285.  
  1286. function FltNeg(P: Float; Negate: Boolean): Float;
  1287. begin
  1288.   if Negate then Result:=-P else Result:=P;
  1289. end;
  1290.  
  1291. function FltMul(P1,P2: Float; Decimals: Integer): Float;
  1292. begin
  1293.   P1    :=fltRound(P1,Decimals);
  1294.   P2    :=fltRound(P2,Decimals);
  1295.   Result:=fltRound(P1*P2,Decimals);
  1296. end;
  1297.  
  1298. function FltRound(P: Float; Decimals: Integer): Float;
  1299. var
  1300.   Factor  : LongInt;
  1301.   Help    : Float;
  1302. begin
  1303.   Factor:=IntPow10(Decimals);
  1304.   if P<0 then Help:=-0.5 else Help:=0.5;
  1305.   Result:=Int(P*Factor+Help)/Factor;
  1306.   if fltEqualZero(Result) then Result:=0.00;
  1307. end;
  1308.  
  1309. function FltSub(P1,P2: Float; Decimals: Integer): Float;
  1310. begin
  1311.   P1    :=fltRound(P1,Decimals);
  1312.   P2    :=fltRound(P2,Decimals);
  1313.   Result:=fltRound(P1-P2,Decimals);
  1314. end;
  1315.  
  1316. function FltUnEqualZero(P: Float): Boolean;
  1317. begin
  1318.   Result:=(P<-FLTZERO) or (P>FLTZERO)
  1319. end;
  1320.  
  1321. function FltCalc(const Expr: String): Float;
  1322. const
  1323.   STACKSIZE = 10;
  1324. var
  1325.   Stack   : array[0..STACKSIZE] of Float;    { 29.10.96 sb }
  1326.   oStack  : array[0..STACKSIZE] of char;
  1327.   z,n     : Float;
  1328.   i,j,m   : integer;
  1329.   Bracket : boolean;
  1330. begin
  1331.   Bracket:= False; j := 0; n:= 1;z:=0; m:=1;
  1332.   for i := 1 to Length(Expr) do
  1333.   begin
  1334.     if not Bracket  then
  1335.        case Expr[i] of
  1336.          '0' .. '9': begin
  1337.                        z:=z*10+ord(Expr[i])-ord('0');
  1338.                        n:=n*m;
  1339.                      end;
  1340.          ',',#46   : m := 10;
  1341.          '('       : Bracket := True; {hier Klammeranfang merken, ZΣhler!!}
  1342.          '*','x',
  1343.          'X',
  1344.          '/','+'   : begin
  1345.                        Stack[j] := z/n;
  1346.                        oStack[j] := Expr[i];
  1347.                        Inc(j);
  1348.                        m:=1;z:=0;n:=1;
  1349.                      end;
  1350.        end {case}
  1351.     else
  1352.        Bracket:= Expr[i]<> ')'; {hier Rekursiver Aufruf, ZΣhler !!};
  1353.   end;
  1354.   Stack[j] := z/n;
  1355.   for i := 1 to j do
  1356.     case oStack[i-1] of
  1357.       '*','x','X' :  Stack[i]:= Stack[i-1]*Stack[i];
  1358.       '/'         :  Stack[i]:= Stack[i-1]/Stack[i];
  1359.       '+'         :  Stack[i]:= Stack[i-1]+Stack[i];
  1360.     end;
  1361.   Result:= Stack[j];
  1362. end;
  1363.  
  1364. function fltPower(a, n: Float): Float;
  1365. begin
  1366.   Result:=Exp(n * Ln(a));
  1367. end;
  1368.  
  1369. function fltPositiv(Value: Float): Float;
  1370. begin
  1371.   Result:=Value;
  1372.   if Value < 0.0 then Result:= 0.0;
  1373. end;
  1374.  
  1375. function fltNegativ(Value: Float): Float;
  1376. begin
  1377.   Result:=Value;
  1378.   if Value > 0.0 then Result:= 0.0;
  1379. end;
  1380.  
  1381. { Rectangle Calculations }
  1382.  
  1383. function RectHeight(const R: TRect): Integer;
  1384. begin
  1385.   Result := R.Bottom - R.Top;
  1386. end;
  1387.  
  1388. function RectWidth(const R: TRect): Integer;
  1389. begin
  1390.   Result := R.Right - R.Left;
  1391. end;
  1392.  
  1393. procedure RectGrow(var R: TRect; Delta: Integer);
  1394. begin
  1395.   with R do
  1396.   begin
  1397.     Dec(Left, Delta);
  1398.     Dec(Top, Delta);
  1399.     Inc(Right, Delta);
  1400.     Inc(Bottom, Delta);
  1401.   end;
  1402. end;
  1403.  
  1404. procedure RectRelativeMove(var R: TRect; DX, DY: Integer);
  1405. begin
  1406.   with R do
  1407.   begin
  1408.     Inc(Left, DX);
  1409.     Inc(Right, DX);
  1410.     Inc(Top, DY);
  1411.     Inc(Bottom, DY);
  1412.   end;
  1413. end;
  1414.  
  1415. procedure RectMoveTo(var R: TRect; X, Y: Integer);
  1416. begin
  1417.   with R do
  1418.   begin
  1419.     Right := X + Right - Left;
  1420.     Bottom := Y + Bottom - Top;
  1421.     Left := X;
  1422.     Top := Y;
  1423.   end;
  1424. end;
  1425.  
  1426. function RectSet(Left, Top, Right, Bottom: Integer): TRect;
  1427. begin
  1428.   Result.Left := Left;
  1429.   Result.Top := Top;
  1430.   Result.Right := Right;
  1431.   Result.Bottom := Bottom;
  1432. end;
  1433.  
  1434. function RectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
  1435. begin
  1436.   Result.TopLeft := TopLeft;
  1437.   Result.BottomRight := BottomRight;
  1438. end;
  1439.  
  1440. function RectInclude(const R1, R2: TRect): Boolean;
  1441. begin
  1442.   Result := (R1.Left >= R2.Left) and (R1.Top >= R2.Top)
  1443.     and (R1.Right <= R2.Right) and (R1.Bottom <= R2.Bottom);
  1444. end;
  1445.  
  1446. function  RectPoint(const R: TRect; P: TPoint): Boolean;
  1447. begin
  1448.   Result := (p.x>r.left) and (p.x<r.right) and (p.y>r.top) and (p.y<r.bottom);
  1449. end;
  1450.  
  1451. function RectIntersection(const R1, R2: TRect): TRect;
  1452. begin
  1453.   with Result do
  1454.   begin
  1455.     Left := intMax(R1.Left, R2.Left);
  1456.     Top := intMax(R1.Top, R2.Top);
  1457.     Right := intMin(R1.Right, R2.Right);
  1458.     Bottom := intMin(R1.Bottom, R2.Bottom);
  1459.   end;
  1460.  
  1461.   if not RectIsValid(Result) then
  1462.     Result := RectSet(0, 0, 0, 0);
  1463. end;
  1464.  
  1465. function RectIsIntersection(const R1, R2: TRect): Boolean;
  1466. begin
  1467.   Result := not RectIsNull(RectIntersection(R1, R2));
  1468. end;
  1469.  
  1470. function RectIsValid(const R: TRect): Boolean;
  1471. begin
  1472.   with R do
  1473.     Result := (Left <= Right) and (Top <= Bottom);
  1474. end;
  1475.  
  1476. function RectsAreValid(const Arr: array of TRect): Boolean;
  1477. var
  1478.   I: Integer;
  1479. begin
  1480.   for I := Low(Arr) to High(Arr) do
  1481.     if not RectIsValid(Arr[I]) then
  1482.     begin
  1483.       Result := False;
  1484.       exit;
  1485.     end;
  1486.   Result := True;
  1487. end;
  1488.  
  1489. function RectNull: TRect;
  1490. begin
  1491.   Result := RectSet(0, 0, 0, 0);
  1492. end;
  1493.  
  1494. function RectIsNull(const R: TRect): Boolean;
  1495. begin
  1496.   with R do
  1497.     Result := (Left = 0) and (Right = 0) and (Top = 0) and (Bottom = 0);
  1498. end;
  1499.  
  1500. function RectIsSquare(const R: TRect): Boolean;
  1501. begin
  1502.   Result := RectHeight(R) = RectWidth(R);
  1503. end;
  1504.  
  1505. function RectCentralPoint(const R: TRect): TPoint;
  1506. begin
  1507.   Result.X := R.Left + (RectWidth(R) div 2);
  1508.   Result.Y := R.Top + (RectHeight(R) div 2);
  1509. end;
  1510.  
  1511. function  rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;
  1512. begin
  1513.   Result:=rectSet(aLeft,aTop,aLeft+aWidth,aTop+aHeight);
  1514. end;
  1515.  
  1516. { variant functions }
  1517.  
  1518. {$IFDEF Win32}
  1519. function varIIF( aTest: Boolean; TrueValue, FalseValue : Variant): Variant;
  1520. begin
  1521.   if aTest then  Result := TrueValue else Result := FalseValue;
  1522. end;
  1523.  
  1524. procedure varDebug(const V: Variant);
  1525. begin
  1526.    strDebug(varToStr(v));
  1527. end;
  1528.  
  1529. function varToStr(const V: Variant): String;
  1530. begin
  1531.   case TVarData(v).vType of
  1532.     varSmallInt : Result := IntToStr(TVarData(v).VSmallInt);
  1533.     varInteger  : Result := IntToStr(TVarData(v).VInteger);
  1534.     varSingle   : Result := FloatToStr(TVarData(v).VSingle);
  1535.     varDouble   : Result := FloatToStr(TVarData(v).VDouble);
  1536.     varCurrency : Result := FloatToStr(TVarData(v).VCurrency);
  1537.     varDate     : Result := DateToStr(TVarData(v).VDate);
  1538.     varBoolean  : Result := varIIf(TVarData(v).VBoolean, 'True', 'False');
  1539.     varByte     : Result := IntToStr(TVarData(v).VByte);
  1540.     varString   : Result := StrPas(TVarData(v).VString);
  1541.     varEmpty,
  1542.     varNull,
  1543.     varVariant,
  1544.     varUnknown,
  1545.     varTypeMask,
  1546.     varArray,
  1547.     varByRef,
  1548.     varDispatch,
  1549.     varError    : Result := '';
  1550.   end;
  1551. end;
  1552.  
  1553. {$ENDIF}
  1554.  
  1555.  
  1556. { file functions }
  1557.  
  1558. procedure fileShredder(const Filename: String);
  1559. var
  1560.   aFile : Integer;
  1561.   aSize : Integer;
  1562.   P     : Pointer;
  1563. begin
  1564.   aSize:=fileSize(Filename);
  1565.   aFile:=FileOpen(FileName,fmOpenReadWrite);
  1566.   try
  1567.     Getmem(P,aSize);
  1568.     fillchar(P^,aSize,'X');
  1569.     FileWrite(aFile,P^,aSize);
  1570.     Freemem(P,aSize);
  1571.   finally
  1572.     FileClose(aFile);
  1573.     DeleteFile(Filename);
  1574.   end;
  1575. end;
  1576.  
  1577. function fileSize(const FileName: String): LongInt;
  1578. var
  1579.   SearchRec       : TSearchRec;
  1580. begin                                       { !Win32! -> GetFileSize }
  1581.   if FindFirst(FileName,faAnyFile,SearchRec)=0
  1582.     then Result:=SearchRec.Size
  1583.     else Result:=0;
  1584. end;
  1585.  
  1586. function fileWildcard(const Filename: String): Boolean;
  1587. begin
  1588.   Result:=(Pos('*',Filename)<>0) or (Pos('?',Filename)<>0);
  1589. end;
  1590.  
  1591. function fileShellOpen(const aFile: String): Boolean;
  1592. var
  1593.   Tmp: array[0..100] of char;
  1594. begin
  1595.   Result := ShellExecute( Application.Handle,
  1596.     'open', StrPCopy(Tmp,aFile), nil, nil, SW_NORMAL) > 32;
  1597. end;
  1598.  
  1599. function fileShellPrint(const aFile: String): Boolean;
  1600. var
  1601.   Tmp: array[0..100] of char;
  1602. begin
  1603.   Result := ShellExecute( Application.Handle,
  1604.     'print', StrPCopy(Tmp,aFile), nil, nil, SW_HIDE) > 32;
  1605. end;
  1606.  
  1607. function fileCopy(const SourceFile, TargetFile: String): Boolean;
  1608. const
  1609.   BlockSize = 1024 * 16;
  1610. var
  1611.   FSource,FTarget : Integer;
  1612.   FFileSize       : Longint;
  1613.   BRead,Bwrite    : Word;
  1614.   Buffer          : Pointer;
  1615. begin
  1616.   Result:=False;
  1617.   FSource:=FileOpen(SourceFile,fmOpenRead+fmShareDenyNone);  { Open Source }
  1618.   if FSource>=0 then
  1619.   try
  1620.     FFileSize:=FileSeek(FSource, 0, soFromEnd);
  1621.     FTarget:=FileCreate(TargetFile);            { Open Target }
  1622.     try
  1623.       getmem(Buffer,BlockSize);
  1624.       try
  1625.         FileSeek(FSource,0,soFromBeginning);
  1626.         repeat
  1627.           BRead:=FileRead(FSource,Buffer^,BlockSize);
  1628.           BWrite:=FileWrite(FTarget,Buffer^,Bread);
  1629.         until (Bread=0) or (Bread<>BWrite);
  1630.         if Bread=Bwrite then
  1631.            Result:=True;
  1632.       finally
  1633.         freemem(Buffer,BlockSize);
  1634.       end;
  1635.       FileSetDate(FTarget, FileGetDate(FSource));
  1636.     finally
  1637.       FileClose(FTarget);
  1638.     end;
  1639.   finally
  1640.     FileClose(FSource);
  1641.   end;
  1642. end;
  1643.  
  1644.  
  1645. {$IFDEF Win32}
  1646. function fileTemp(const aExt: String): String;
  1647. var
  1648.   Buffer: array[0..1023] of Char;
  1649.   aFile : String;
  1650. begin
  1651.   GetTempPath(Sizeof(Buffer)-1,Buffer);
  1652.   GetTempFileName(Buffer,'TMP',0,Buffer);
  1653.   SetString(aFile, Buffer, StrLen(Buffer));
  1654.   Result:=ChangeFileExt(aFile,aExt);
  1655.   RenameFile(aFile,Result);
  1656. end;
  1657.  
  1658. function fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
  1659. var
  1660.   StartupInfo : TStartupInfo;
  1661.   ProcessInfo : TProcessInformation;
  1662. begin
  1663.   {setup the startup information for the application }
  1664.   FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  1665.   with StartupInfo do
  1666.   begin
  1667.     cb:= SizeOf(TStartupInfo);
  1668.     dwFlags:= STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
  1669.     if aHide then wShowWindow:= SW_HIDE
  1670.              else wShowWindow:= SW_SHOWNORMAL;
  1671.   end;
  1672.  
  1673.   Result := CreateProcess(nil,PChar(aCmdLine), nil, nil, False,
  1674.                NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
  1675.   if aWait then
  1676.      if Result then
  1677.      begin
  1678.        WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
  1679.        WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
  1680.      end;
  1681. end;
  1682.  
  1683. function fileRedirectExec(const aCmdLine: String; Strings: TStrings): Boolean;
  1684. var
  1685.   StartupInfo : TStartupInfo;
  1686.   ProcessInfo : TProcessInformation;
  1687.   aOutput     : Integer;
  1688.   aFile       : String;
  1689. begin
  1690.   Strings.Clear;
  1691.  
  1692.   { Create temp. file for output }
  1693.   aFile:=FileTemp('.tmp');
  1694.   aOutput:=FileCreate(aFile);
  1695.   try
  1696.     {setup the startup information for the application }
  1697.     FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  1698.     with StartupInfo do
  1699.     begin
  1700.       cb:= SizeOf(TStartupInfo);
  1701.       dwFlags:= STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK or
  1702.                 STARTF_USESTDHANDLES;
  1703.       wShowWindow:= SW_HIDE;
  1704.       hStdInput:= INVALID_HANDLE_VALUE;
  1705.       hStdOutput:= aOutput;
  1706.       hStdError:= INVALID_HANDLE_VALUE;
  1707.     end;
  1708.  
  1709.     Result := CreateProcess(nil,PChar(aCmdLine), nil, nil, False,
  1710.                  NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
  1711.     if Result then
  1712.     begin
  1713.       WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
  1714.       WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
  1715.     end;
  1716.   finally
  1717.     FileClose(aOutput);
  1718.     Strings.LoadFromFile(aFile);
  1719.     DeleteFile(aFile);
  1720.   end;
  1721. end;
  1722.  
  1723.  
  1724. function  fileLongName(const aFile: String): String;
  1725. var
  1726.   aInfo: TSHFileInfo;
  1727. begin
  1728.   if SHGetFileInfo(PChar(aFile),0,aInfo,Sizeof(aInfo),SHGFI_DISPLAYNAME)<>0 then
  1729.      Result:=StrPas(aInfo.szDisplayName)
  1730.   else
  1731.      Result:=aFile;
  1732. end;
  1733.  
  1734. function  fileTypeName(const aFile: String): String;
  1735. var
  1736.   aInfo: TSHFileInfo;
  1737. begin
  1738.   if SHGetFileInfo(PChar(aFile),0,aInfo,Sizeof(aInfo),SHGFI_TYPENAME)<>0 then
  1739.      Result:=StrPas(aInfo.szTypeName)
  1740.   else begin
  1741.      Result:=ExtractFileExt(aFile);
  1742.      Delete(Result,1,1);
  1743.      Result:=strUpper(Result)+' File';
  1744.   end;
  1745. end;
  1746.  
  1747.  
  1748. function  fileShortName(const aFile: String): String;
  1749. var
  1750.   aTmp: array[0..255] of char;
  1751. begin
  1752.   if GetShortPathName(PChar(aFile),aTmp,Sizeof(aTmp)-1)=0 then
  1753.      Result:=aFile
  1754.   else
  1755.      Result:=StrPas(aTmp);
  1756. end;
  1757.  
  1758. {$ENDIF}
  1759.  
  1760. function ExtractName(const Filename: String): String;
  1761. var
  1762.   aExt : String;
  1763.   aPos : Integer;
  1764. begin
  1765.   aExt:=ExtractFileExt(Filename);
  1766.   Result:=ExtractFileName(Filename);
  1767.   if aExt <> '' then
  1768.   begin
  1769.     aPos:=Pos(aExt,Result);
  1770.     if aPos>0 then
  1771.        Delete(Result,aPos,Length(aExt));
  1772.   end;
  1773. end;
  1774.  
  1775. { date calculations }
  1776.  
  1777. function  dateYear(D: TDateTime): Integer;
  1778. var
  1779.   Year,Month,Day : Word;
  1780. begin
  1781.   DecodeDate(D,Year,Month,Day);
  1782.   Result:=Year;
  1783. end;
  1784.  
  1785. function  dateMonth(D: TDateTime): Integer;
  1786. var
  1787.   Year,Month,Day : Word;
  1788. begin
  1789.   DecodeDate(D,Year,Month,Day);
  1790.   Result:=Month;
  1791. end;
  1792.  
  1793. function  dateBeginOfYear(D: TDateTime): TDateTime;
  1794. var
  1795.   Year,Month,Day : Word;
  1796. begin
  1797.   DecodeDate(D,Year,Month,Day);
  1798.   Result:=EncodeDate(Year,1,1);
  1799. end;
  1800.  
  1801. function  dateEndOfYear(D: TDateTime): TDateTime;
  1802. var
  1803.   Year,Month,Day : Word;
  1804. begin
  1805.   DecodeDate(D,Year,Month,Day);
  1806.   Result:=EncodeDate(Year,12,31);
  1807. end;
  1808.  
  1809. function  dateBeginOfMonth(D: TDateTime): TDateTime;
  1810. var
  1811.   Year,Month,Day : Word;
  1812. begin
  1813.   DecodeDate(D,Year,Month,Day);
  1814.   Result:=EncodeDate(Year,Month,1);
  1815. end;
  1816.  
  1817. function  dateEndOfMonth(D: TDateTime): TDateTime;
  1818. var
  1819.   Year,Month,Day : Word;
  1820. begin
  1821.   DecodeDate(D,Year,Month,Day);
  1822.   if Month=12 then
  1823.   begin
  1824.     Inc(Year);
  1825.     Month:=1;
  1826.   end else
  1827.     Inc(Month);
  1828.   Result:=EncodeDate(Year,Month,1)-1;
  1829. end;
  1830.  
  1831. function dateWeekOfYear(D: TDateTime): Integer; { Armin Hanisch }
  1832. const
  1833.   t1: array[1..7] of ShortInt = ( -1,  0,  1,  2,  3, -3, -2);
  1834.   t2: array[1..7] of ShortInt = ( -4,  2,  1,  0, -1, -2, -3);
  1835. var
  1836.   doy1,
  1837.   doy2    : Integer;
  1838.   NewYear : TDateTime;
  1839. begin
  1840.   NewYear:=dateBeginOfYear(D);
  1841.   doy1 := dateDayofYear(D) + t1[DayOfWeek(NewYear)];
  1842.   doy2 := dateDayofYear(D) + t2[DayOfWeek(D)];
  1843.   if doy1 <= 0 then
  1844.     Result := dateWeekOfYear(NewYear-1)
  1845.   else if (doy2 >= dateDayofYear(dateEndOfYear(NewYear))) then
  1846.     Result:= 1
  1847.   else
  1848.     Result:=(doy1-1) div 7+1;
  1849. end;
  1850.  
  1851. function dateDayOfYear(D: TDateTime): Integer;
  1852. begin
  1853.   Result:=Trunc(D-dateBeginOfYear(D))+1;
  1854. end;
  1855.  
  1856. function dateDayOfWeek(D: TDateTime): TDayOfWeek;
  1857. begin
  1858.   Result:=TDayOfWeek(Pred(DayOfWeek(D)));
  1859. end;
  1860.  
  1861. function dateLeapYear(D: TDateTime): Boolean;
  1862. var
  1863.   Year,Month,Day: Word;
  1864. begin
  1865.   DecodeDate(D,Year,Month,Day);
  1866.   Result:=(Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
  1867. end;
  1868.  
  1869. function dateBeginOfQuarter(D: TDateTime):TDateTime;
  1870. var
  1871.   Year,Month,Day : Word;
  1872. begin
  1873.   DecodeDate(D,Year,Month,Day);
  1874.   Result:=EncodeDate(Year,((Month-1 div 3) * 3)+1,1);
  1875. end;
  1876.  
  1877. function dateEndOfQuarter(D: TDateTime): TDateTime;
  1878. begin
  1879.   Result:=dateBeginOfQuarter(dateBeginOfQuarter(D)+(3*31))-1;
  1880. end;
  1881.  
  1882. function dateBeginOfWeek(D: TDateTime; Weekday: Integer): TDateTime;
  1883. begin
  1884.   Result:=D;
  1885.   while DayOfWeek(Result)<>Weekday do Result:=Result-1;
  1886. end;
  1887.  
  1888. function dateDaysInMonth(D: TDateTime): Integer;
  1889. const
  1890.   DaysPerMonth: array[1..12] of Byte= (31,28,31,30,31,30,31,31,30,31,30,31);
  1891. var
  1892.   Month: Integer;
  1893. begin
  1894.   Month:=dateMonth(D);
  1895.   Result:=DaysPerMonth[Month];
  1896.   if (Month=2) and dateLeapYear(D) then Inc(Result);
  1897. end;
  1898.  
  1899. function dateDay(D: TDateTime): Integer;
  1900. var
  1901.   Year,Month,Day : Word;
  1902. begin
  1903.   DecodeDate(D,Year,Month,Day);
  1904.   Result:=Day;
  1905. end;
  1906.  
  1907. function dateQuicken(D: TDateTime; var Key: Char): TDateTime;
  1908. const
  1909.  {$IFDEF German}
  1910.   _ToDay    = 'H';
  1911.   _PrevYear = 'J';
  1912.   _NextYear = 'R';
  1913.   _PrevMonth= 'M';
  1914.   _NextMonth= 'T';
  1915.   _BeginQuart='Q';
  1916.   _EndQuart  ='U';
  1917.  {$ELSE}
  1918.   _ToDay    = 'T';
  1919.   _PrevYear = 'Y';
  1920.   _NextYear = 'R';
  1921.   _PrevMonth= 'M';
  1922.   _NextMonth= 'H';
  1923.   _BeginQuart='Q';
  1924.   _EndQuart  ='U';
  1925.  {$ENDIF}
  1926. begin
  1927.   case Upcase(Key) of                     { Quicken Date Fast Keys }
  1928.     '+'        : Result := D+1;
  1929.     '-'        : Result := D-1;
  1930.     _ToDay     : Result := Date;
  1931.     _PrevYear  : if D <> dateBeginOfYear(D)  then Result:=dateBeginOfYear(D)
  1932.                                              else Result:=dateBeginOfYear(D-1);
  1933.     _NextYear  : if D <> dateEndOfYear(D)    then Result:=dateEndOfYear(D)
  1934.                                              else Result:=dateEndOfYear(Date+1);
  1935.     _PrevMonth : if D <> dateBeginOfMonth(D) then Result:=dateBeginOfMonth(D)
  1936.                                              else Result:=dateBeginOfMonth(D-1);
  1937.     _NextMonth : if D <> dateEndOfMonth(D)   then Result:=dateEndOfMonth(D)
  1938.                                              else Result:=dateEndOfMonth(D+1);
  1939.     _BeginQuart: Result := dateBeginOfQuarter(D);
  1940.     _EndQuart  : Result := dateEndOfQuarter(D);
  1941.     else begin
  1942.       Result := D;
  1943.       exit;
  1944.     end;
  1945.   end;
  1946.   Key:=#0;
  1947. end;
  1948.  
  1949. { time functions }
  1950.  
  1951. function  timeHour(T: TDateTime): Integer;
  1952. var
  1953.   Hour,Minute,Sec,Sec100: Word;
  1954. begin
  1955.   DecodeTime(T,Hour,Minute,Sec,Sec100);
  1956.   Result:=Hour;
  1957. end;
  1958.  
  1959. function  timeMin(T: TDateTime): Integer;
  1960. var
  1961.   Hour,Minute,Sec,Sec100: Word;
  1962. begin
  1963.   DecodeTime(T,Hour,Minute,Sec,Sec100);
  1964.   Result:=Minute;
  1965. end;
  1966.  
  1967. function  timeSec(T: TDateTime): Integer;
  1968. var
  1969.   Hour,Minute,Sec,Sec100: Word;
  1970. begin
  1971.   DecodeTime(T,Hour,Minute,Sec,Sec100);
  1972.   Result:=Sec;
  1973. end;
  1974.  
  1975. function  timeToInt(T: TDateTime): Integer;
  1976. begin
  1977.   Result:=Trunc((MSecsPerday * T) / 1000);
  1978. end;
  1979.  
  1980. {$IFDEF Win32}
  1981. function  timeZoneOffset: Integer;
  1982. var
  1983.   aTimeZoneInfo : TTimeZoneInformation;
  1984. begin
  1985.   if GetTimeZoneInformation(aTimeZoneInfo)<>-1 then
  1986.      Result := aTimeZoneInfo.Bias
  1987.   else
  1988.      Result := 0;
  1989. end;
  1990. {$ENDIF}
  1991.  
  1992. { Communications Functions }
  1993.  
  1994. function  comIsCis(const S: String): Boolean;
  1995. var
  1996.   aSt: String;
  1997.   PreId,
  1998.   PostId: Integer;
  1999. begin
  2000.   Result:=strContainsU('@compuserve.com',S);     { 28.7.96 sb This is also on CIS }
  2001.   if not Result then
  2002.      if Pos(',',S) > 0 then
  2003.      try
  2004.        aSt:=S;
  2005.        PreId:=StrToInt(strToken(aSt,','));
  2006.        PostId:=StrToInt(aSt);
  2007.        Result:=(PreId > 0) and (PostId > 0);
  2008.      except
  2009.        Result:=False;
  2010.      end;
  2011. end;
  2012.  
  2013. function  comIsInt(const S: String): Boolean;
  2014. var
  2015.   aSt : String;
  2016.   PreId,
  2017.   PostId : String;
  2018. begin
  2019.   try
  2020.     aSt:=S;
  2021.     PreId:=strToken(aSt,'@');
  2022.     PostId:=aSt;
  2023.     Result:=(Length(PreId)>0) and (Length(PostId)>0);
  2024.   except
  2025.     Result:=False;
  2026.   end;
  2027. end;
  2028.  
  2029. { converts a CIS adress to a correct Internet adress }
  2030. function  comCisToInt(const S: String): String;
  2031. var
  2032.   P : Integer;
  2033. begin
  2034.   p:=Pos('INTERNET:',S);
  2035.   if P=1 then
  2036.     Result:=Copy(S,P+1,Length(S))
  2037.   else
  2038.   begin
  2039.     Result:=S;
  2040.     P:=Pos(',',Result);
  2041.     if P>0 then Result[P]:='.';
  2042.     Result:=Result+'@compuserve.com';     { 22.07.96 sb  Error }
  2043.   end;
  2044. end;
  2045.  
  2046. { converts a internet adress to a correct CServe adress }
  2047. function  comIntToCis(const S: String): String;
  2048. var
  2049.   P : Integer;
  2050. begin
  2051.   p:=Pos('@COMPUSERVE.COM',strUpper(S));
  2052.   if p > 0 then
  2053.   begin
  2054.     Result:=strLeft(S,P-1);
  2055.     P:=Pos('.',Result);
  2056.     if P>0 then Result[P]:=',';
  2057.   end else
  2058.     Result:='INTERNET:'+S;
  2059. end;
  2060.  
  2061. { converts a fax adress to a correct CServe adress }
  2062. function  comFaxToCis(const S: String): String;
  2063. begin
  2064.   Result:='FAX:'+S;
  2065. end;
  2066.  
  2067. function comNormFax(const Name, Fax: String): String;
  2068. begin
  2069.   if Name<>'' then
  2070.      Result:=Name+'[fax: '+Name+'@'+strTrim(Fax)+']'
  2071.   else
  2072.      Result:='[fax: '+strTrim(Fax)+']';
  2073. end;
  2074.  
  2075. function  comNormInt(const Name,Int: String): String;
  2076. begin
  2077.   Result:='';
  2078.   if comIsInt(Int) then
  2079.      if Name <> '' then
  2080.         Result := Name + '|smtp: ' + strTrim(Int)
  2081.      else
  2082.         Result := 'smtp: ' + strTrim(Int);
  2083. end;
  2084.  
  2085. function  comNormCis(const Name,Cis: String): String;
  2086. begin
  2087.   Result:='';
  2088.   if Name <> '' then
  2089.      Result := Name + '[compuserve: ' + strTrim(Cis) + ']'
  2090.   else
  2091.      Result := '[compuserve: ' + strTrim(Cis) + ']';
  2092. end;
  2093.  
  2094. function  comNormPhone(const Phone: String): String;
  2095.  
  2096.   function strValueAt(const S:String; At: Integer): String;
  2097.   const
  2098.     Seperator = ',';
  2099.     Str = '"';
  2100.   var
  2101.     j,i: Integer;
  2102.     FSkip : Boolean;
  2103.   begin
  2104.     Result:='';
  2105.     j := 1;
  2106.     i := 0;
  2107.     FSkip:= False;
  2108.     while (i<=At ) and (j<=Length(S)) do
  2109.     begin
  2110.       if (S[j]=Str) then
  2111.          FSkip:=not FSkip
  2112.       else if (S[j]=Seperator) and not FSkip then
  2113.          Inc(i)
  2114.       else if i = At then
  2115.          Result:=Result+S[j];
  2116.       Inc(j);
  2117.     end;
  2118.   end;
  2119.  
  2120. var
  2121.   aNumber,
  2122.   aCountry,
  2123.   aPrefix,
  2124.   aDefault,
  2125.   aLocation  : String;
  2126.  
  2127.   i          : Integer;
  2128. begin
  2129.   aDefault  := '1,"Hamburg","","","40",49,0,0,0,"",1," "';
  2130.   aLocation := strProfile('telephon.ini','Locations','CurrentLocation','');
  2131.   if aLocation <> '' then
  2132.   begin
  2133.     aLocation:=strTokenAt(aLocation,',',0);
  2134.     if aLocation <> '' then
  2135.     begin
  2136.       aLocation:=strProfile('telephon.ini','Locations','Location'+aLocation,'');
  2137.       if aLocation <> '' then
  2138.          aDefault := aLocation;
  2139.     end;
  2140.   end;
  2141.  
  2142.   Result:='';
  2143.   aNumber:=strTrim(Phone);
  2144.   if aNumber <> '' then
  2145.     for i:=Length(aNumber) downto 1 do
  2146.       if not (aNumber[i] in DIGITS) then
  2147.       begin
  2148.         if aNumber[i] <> '+' then aNumber[i] := '-';
  2149.         if i < Length(aNumber) then                    { remove duplicate digits }
  2150.            if aNumber[i]=aNumber[i+1] then
  2151.               Delete(aNumber,i,1);
  2152.       end;
  2153.  
  2154.   if aNumber <> '' then
  2155.   begin
  2156.     if aNumber[1] = '+' then
  2157.        aCountry := strToken(aNumber,'-')
  2158.     else
  2159.        aCountry := '+'+strValueAt(aDefault,5);
  2160.  
  2161.     aNumber:=strTrimChL(aNumber,'-');
  2162.  
  2163.     if aNumber <> '' then
  2164.     begin
  2165.       if strTokenCount(aNumber,'-') > 1 then
  2166.          aPrefix := strTrimChL(strToken(aNumber,'-'),'0')
  2167.       else
  2168.          aPrefix := strValueAt(aDefault,4);
  2169.  
  2170.       aNumber:= strNicePhone(strTrimChA(aNumber,'-'));
  2171.       Result := aCountry + ' ('+aPrefix+') '+aNumber;
  2172.     end;
  2173.   end;
  2174. end;
  2175.  
  2176. { system functions }
  2177.  
  2178. {$IFDEF Win32}
  2179. function sysTempPath: String;
  2180. var
  2181.   Buffer: array[0..1023] of Char;
  2182. begin
  2183.   SetString(Result, Buffer, GetTempPath(Sizeof(Buffer)-1,Buffer));
  2184. end;
  2185. {$ELSE}
  2186. function sysTempPath:String;
  2187. var
  2188.   Buffer: array[0..255] of char;
  2189. begin
  2190.   GetTempFileName(#0,'TMP',0,Buffer);             { 15.07.96 sb }
  2191.   Result:=StrPas(Buffer);
  2192.   DeleteFile(Result);
  2193.   Result:=ExtractFilePath(Result);
  2194. end;
  2195. {$ENDIF}
  2196.  
  2197. procedure sysDelay(aMs: Longint);
  2198. var
  2199.   TickCount       : LongInt;
  2200. begin
  2201.   TickCount:=GetTickCount;
  2202.   while GetTickCount - TickCount < aMs do Application.ProcessMessages;
  2203. end;
  2204.  
  2205. procedure sysBeep;
  2206. begin
  2207.   messageBeep($FFFF);
  2208. end;
  2209.  
  2210. function sysColorDepth: Integer;
  2211. var
  2212.   aDC: hDC;
  2213. begin
  2214.   Result:=0;
  2215.   try
  2216.     aDC := GetDC(0);
  2217.     Result:=1 shl (GetDeviceCaps(aDC,PLANES) * GetDeviceCaps(aDC, BITSPIXEL));
  2218.   finally
  2219.     ReleaseDC(0,aDC);
  2220.   end;
  2221. end;
  2222.  
  2223. {$IFDEF Win32}
  2224. procedure sysSaverRunning(Active: Boolean);
  2225. var
  2226.   aParam: Longint;
  2227. begin
  2228.   SystemParametersInfo (SPI_SCREENSAVERRUNNING, Word(Active),@aParam,0);
  2229. end;
  2230. {$ENDIF}
  2231.  
  2232. { registry functions }
  2233.  
  2234. {$IFDEF Win32 }
  2235.  
  2236. procedure regParsePath(const Path: String; var aPath, aValue: String);
  2237. begin
  2238.   aPath:=Path;
  2239.   aValue:= '';
  2240.   while (Length(aPath)>0) and (strLastCh(aPath)<>'\') do
  2241.   begin
  2242.     aValue:=strLastCh(aPath)+aValue;
  2243.     strStripLast(aPath);
  2244.   end;
  2245. end;
  2246.  
  2247. function regReadString(aKey: HKEY; const Path: String): String;
  2248. var
  2249.   aRegistry : TRegistry;
  2250.   aPath     : String;
  2251.   aValue    : String;
  2252. begin
  2253.   aRegistry:=TRegistry.Create;
  2254.   try
  2255.     with aRegistry do
  2256.     begin
  2257.       RootKey:=aKey;
  2258.       regParsePath(Path, aPath, aValue);
  2259.       OpenKey(aPath,True);
  2260.       Result:=ReadString(aValue);
  2261.     end;
  2262.   finally
  2263.     aRegistry.Free;
  2264.   end;
  2265. end;
  2266.  
  2267. procedure regWriteString(aKey: HKEY; const Path,Value: String);
  2268. var
  2269.   aRegistry : TRegistry;
  2270.   aPath     : String;
  2271.   aValue    : String;
  2272. begin
  2273.   aRegistry:=TRegistry.Create;
  2274.   try
  2275.     with aRegistry do
  2276.     begin
  2277.       RootKey:=aKey;
  2278.       regParsePath(Path, aPath, aValue);
  2279.       OpenKey(aPath,True);
  2280.       WriteString(aValue,Value);
  2281.     end;
  2282.   finally
  2283.     aRegistry.Free;
  2284.   end;
  2285. end;
  2286.  
  2287. procedure regDelValue(aKey: hKey; const Path: String);
  2288. var
  2289.   aRegistry : TRegistry;
  2290.   aPath     : String;
  2291.   aValue    : String;
  2292. begin
  2293.   aRegistry:=TRegistry.Create;
  2294.   try
  2295.     with aRegistry do
  2296.     begin
  2297.       RootKey:=aKey;
  2298.       regParsePath(Path, aPath, aValue);
  2299.       OpenKey(aPath,True);
  2300.       DeleteValue(aValue);
  2301.     end;
  2302.   finally
  2303.     aRegistry.Free;
  2304.   end;
  2305. end;
  2306.  
  2307. (*!!!
  2308. function regReadString(aKey: hKey; const Value: String): String;
  2309. var
  2310.   aTmp  : array[0..255] of char;
  2311.   aCb,
  2312.   aType : Integer;
  2313. begin
  2314.   Result:='';
  2315.   if aKey<> 0 then
  2316.   begin
  2317.     aCb:=Sizeof(aTmp)-1;
  2318.    { aData:=@aTmp; }
  2319.     if RegQueryValueEx(aKey,PChar(Value),nil,@aType,@aTmp,@aCb)=ERROR_SUCCESS then
  2320.        if aType=REG_SZ then Result:=String(aTmp);
  2321.   end;
  2322. end; *)
  2323.  
  2324. function regInfoString(const Value: String): String;
  2325. var
  2326.   aKey : hKey;
  2327. begin
  2328.   Result:='';
  2329.   if RegOpenKey(HKEY_LOCAL_MACHINE,REG_CURRENT_VERSION,aKey)=ERROR_SUCCESS then
  2330.   begin
  2331.     Result:=regReadString(aKey,Value);
  2332.     RegCloseKey(aKey);
  2333.   end;
  2334. end;
  2335.  
  2336. function regCurrentUser: String;
  2337. begin
  2338.   Result:=regInfoString(REG_CURRENT_USER);
  2339. end;
  2340.  
  2341. function regCurrentCompany: String;
  2342. begin
  2343.   Result:=regInfoString(REG_CURRENT_COMPANY);
  2344. end;
  2345.  
  2346. { Add a shell extension to the registry }
  2347. procedure regWriteShellExt(const aExt,aCmd,aMenu,aExec: String);
  2348. var
  2349.   s, aPath : String;
  2350. begin
  2351.   with TRegistry.Create do
  2352.   try
  2353.     RootKey := HKEY_CLASSES_ROOT;
  2354.     aPath   := aExt;
  2355.     if KeyExists(aPath) then
  2356.     begin
  2357.       OpenKey(aPath,False);
  2358.       S:=ReadString('');
  2359.       CloseKey;
  2360.       if S<>'' then
  2361.          if KeyExists(S) then
  2362.             aPath:=S;
  2363.     end;
  2364.  
  2365.     OpenKey(aPath+'\Shell\'+aCmd,True);
  2366.     WriteString('',aMenu);
  2367.     CloseKey;
  2368.  
  2369.     OpenKey(aPath+'\Shell\'+aCmd+'\Command',True);
  2370.     WriteString('',aExec + ' %1');
  2371.     CloseKey;
  2372.   finally
  2373.     Free;
  2374.   end;
  2375. end;
  2376.  
  2377. procedure regValueList(aKey: HKEY; const Path:String; var aValue: TStringList);
  2378. var
  2379.   aRegistry: TRegistry;
  2380. begin
  2381.   aRegistry:=TRegistry.Create;
  2382.   try
  2383.     with aRegistry do
  2384.     begin
  2385.       RootKey:=aKey;
  2386.       OpenKey(Path,True);
  2387.       GetValueNames(aValue);
  2388.     end;
  2389.   finally
  2390.     aRegistry.Free;
  2391.   end;
  2392. end;
  2393.  
  2394. procedure regKeyList(aKey: HKEY; const Path:String; var aValue: TStringList);
  2395. var
  2396.   aRegistry: TRegistry;
  2397. begin
  2398.   aRegistry:=TRegistry.Create;
  2399.   try
  2400.     with aRegistry do
  2401.     begin
  2402.       RootKey:=aKey;
  2403.       OpenKey(Path,True);
  2404.       GetKeyNames(aValue);
  2405.     end;
  2406.   finally
  2407.     aRegistry.Free;
  2408.   end;
  2409. end;
  2410.  
  2411. function regValueExist(aKey: HKEY; const Path:String):Boolean;
  2412. var
  2413.   aRegistry: TRegistry;
  2414.   aPath: String;
  2415.   aValue: String;
  2416. begin
  2417.   aRegistry:=TRegistry.Create;
  2418.   try
  2419.     with aRegistry do
  2420.     begin
  2421.       RootKey:=aKey;
  2422.       regParsePath(Path, aPath, aValue);
  2423.       OpenKey(aPath,True);
  2424.       Result := ValueExists(aValue)
  2425.     end;
  2426.   finally
  2427.     aRegistry.Free;
  2428.   end;
  2429. end;
  2430.  
  2431. function  regReadValue(aKey:HKEY; const Path:String; Typ: TDataType): Variant;
  2432. var
  2433.   aRegistry: TRegistry;
  2434.   aPath: String;
  2435.   aValue: String;
  2436. begin
  2437.   aRegistry:=TRegistry.Create;
  2438.   try
  2439.     with aRegistry do
  2440.     begin
  2441.       RootKey:=aKey;
  2442.       regParsePath(Path, aPath, aValue);
  2443.       if OpenKey(aPath,True) then
  2444.         if ValueExists(aValue) then
  2445.            case Typ of
  2446.              dtInteger:  Result := ReadInteger(aValue);
  2447.              dtBoolean:  Result := ReadBool(aValue);
  2448.              dtString:   Result := ReadString(aValue);
  2449.              dtDate:     Result := ReadDate(aValue);
  2450.              dtFloat:    Result := ReadFloat(aValue);
  2451.              dtCurrency: Result := ReadCurrency(aValue);
  2452.              dtTime:     Result := REadTime(aValue);
  2453.            end;
  2454.     end;
  2455.   finally
  2456.     aRegistry.Free;
  2457.   end;
  2458. end;
  2459.  
  2460. function  regWriteValue(aKey: HKEY; const Path: String; Value: Variant; Typ: TDataType): Boolean;
  2461. var
  2462.   aRegistry : TRegistry;
  2463.   aPath     : String;
  2464.   aValue    : String;
  2465. begin
  2466.   aRegistry:=TRegistry.Create;
  2467.   try
  2468.     with aRegistry do
  2469.     begin
  2470.       RootKey:=aKey;
  2471.       regParsePath(Path, aPath, aValue);
  2472.       if OpenKey(aPath,True) then
  2473.         case Typ of
  2474.           dtInteger:  WriteInteger(aValue, Value);
  2475.           dtBoolean:  WriteBool(aValue, Value);
  2476.           dtString:   WriteString(aValue, Value);
  2477.           dtDate:     WriteDate(aValue, Value);
  2478.           dtFloat:    WriteFloat(aValue, Value);
  2479.           dtCurrency: WriteCurrency(aValue, Value);
  2480.           dtTime:     WriteTime(aValue, Value);
  2481.         end
  2482.       else
  2483.         Result := False;
  2484.     end;
  2485.   finally
  2486.     aRegistry.Free;
  2487.   end;
  2488. end;
  2489.  
  2490. {$ENDIF}
  2491.  
  2492. { other stuff }
  2493.  
  2494. function MsgBox(const aTitle,aMsg: String; aFlag: Integer): Integer;
  2495. var
  2496.   ActiveWindow : hWnd;
  2497.   WindowList   : Pointer;
  2498.   TmpA         : array[0..200] of char;
  2499.   TmpB         : array[0..100] of char;
  2500. begin
  2501.   ActiveWindow:=GetActiveWindow;
  2502.   WindowList:= DisableTaskWindows(0);
  2503.   try
  2504.     StrPCopy(TmpB,aTitle);
  2505.     StrPCopy(TmpA,aMsg);
  2506.    {$IFDEF Win32}
  2507.     Result:=Windows.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
  2508.    {$ELSE}
  2509.     Result:=WinProcs.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
  2510.    {$ENDIF}
  2511.   finally
  2512.     EnableTaskWindows(WindowList);
  2513.     SetActiveWindow(ActiveWindow);
  2514.   end;
  2515. end;
  2516.  
  2517. function Question(const Msg: String):Boolean;
  2518. begin
  2519.   if IsWin95 or IsWinNT then
  2520.     Result:=MsgBox(LoadStr(SMsgdlgConfirm),Msg, MB_ICONQUESTION or MB_YESNO)=IDYES
  2521.   else
  2522.     Result:=messageDlg(Msg,mtConfirmation,[mbYes,mbNo],0)=mrYes;
  2523. end;
  2524.  
  2525. procedure Information(const Msg: String);
  2526. begin
  2527.   if IsWin95 or IsWinNT then
  2528.      MsgBox(LoadStr(SMsgdlgInformation), Msg, MB_ICONINFORMATION or MB_OK )
  2529.   else
  2530.      messageDlg(Msg,mtInformation,[mbOk],0);
  2531. end;
  2532.  
  2533. function Confirmation(const Msg: String): Word;
  2534. begin
  2535.   if IsWin95 or IsWinNT then
  2536.      case MsgBox(LoadStr(SMsgDlgConfirm),Msg,MB_ICONQUESTION or MB_YESNOCANCEL) of
  2537.        IDYES    : Result := mrYes;
  2538.        IDNO     : Result := mrNo;
  2539.        IDCANCEL : Result := mrCancel;
  2540.        else       Result := mrCancel;
  2541.      end
  2542.   else
  2543.      Result:=MessageDlg(Msg,mtConfirmation,[mbYes,mbNo,mbCancel],0);
  2544. end;
  2545.  
  2546. { TPersistentRect }
  2547.  
  2548. constructor TPersistentRect.Create;
  2549. begin
  2550.   FRect:=rectSet(10,10,100,20);
  2551. end;
  2552.  
  2553. procedure TPersistentRect.Assign(Source: TPersistent);
  2554. var
  2555.  Value: TPersistentRect;
  2556. begin
  2557.   if Value is TPersistentRect then
  2558.   begin
  2559.     Value:=Source as TPersistentRect;
  2560.     FRect:=rectBounds(Value.Left,Value.Top,Value.Width,Value.Height);
  2561.     exit;
  2562.   end;
  2563.   inherited Assign(Source);
  2564. end;
  2565.  
  2566. procedure TPersistentRect.SetLeft(Value: Integer);
  2567. begin
  2568.   if Value<>Left then
  2569.   begin
  2570.     if Assigned(FOnConvert) then
  2571.        Value:=FOnConvert(Self,Value,False);
  2572.     FRect:=rectBounds(Value,Top,Width,Height);
  2573.   end;
  2574. end;
  2575.  
  2576. procedure TPersistentRect.SetTop(Value: Integer);
  2577. begin
  2578.   if Value<>Top then
  2579.   begin
  2580.     if Assigned(FOnConvert) then
  2581.        Value:=FOnConvert(Self,Value,False);
  2582.     FRect:=rectBounds(Left,Value,Width,Height);
  2583.   end;
  2584. end;
  2585.  
  2586. procedure TPersistentRect.SetHeight(Value: Integer);
  2587. begin
  2588.   if Value<>Height then
  2589.   begin
  2590.     if Assigned(FOnConvert) then
  2591.        Value:=FOnConvert(Self,Value,False);
  2592.     FRect:=rectBounds(Left,Top,Width,Value);
  2593.   end;
  2594. end;
  2595.  
  2596. procedure TPersistentRect.SetWidth(Value: Integer);
  2597. begin
  2598.   if Value<>Width then
  2599.   begin
  2600.     if Assigned(FOnConvert) then
  2601.        Value:=FOnConvert(Self,Value,False);
  2602.     FRect:=rectBounds(Left,Top,Value,Height);
  2603.   end;
  2604. end;
  2605.  
  2606. function  TPersistentRect.GetLeft: Integer;
  2607. begin
  2608.   Result:=FRect.Left;
  2609.   if Assigned(FOnConvert) then
  2610.      Result:=FOnConvert(Self,Result,True);
  2611. end;
  2612.  
  2613. function  TPersistentRect.GetTop: Integer;
  2614. begin
  2615.   Result:=FRect.Top;
  2616.   if Assigned(FOnConvert) then
  2617.      Result:=FOnConvert(Self,Result,True);
  2618. end;
  2619.  
  2620. function  TPersistentRect.GetHeight: Integer;
  2621. begin
  2622.   Result:=rectHeight(FRect);
  2623.   if Assigned(FOnConvert) then
  2624.      Result:=FOnConvert(Self,Result,True);
  2625. end;
  2626.  
  2627. function  TPersistentRect.GetWidth: Integer;
  2628. begin
  2629.   Result:=rectWidth(FRect);
  2630.   if Assigned(FOnConvert) then
  2631.      Result:=FOnConvert(Self,Result,True);
  2632. end;
  2633.  
  2634. {$IFDEF Win32}
  2635.  
  2636. { TPersistentRegistry }
  2637.  
  2638. function TPersistentRegistry.ReadComponent(const Name: String;
  2639.                                  Owner, Parent: TComponent): TComponent;
  2640. var
  2641.   DataSize  : Integer;
  2642.   MemStream : TMemoryStream;
  2643.   Reader    : TReader;
  2644. begin
  2645.   Result := nil;
  2646.   DataSize:=GetDataSize(Name);
  2647.   MemStream := TMemoryStream.Create;
  2648.   try
  2649.     MemStream.SetSize(DataSize);
  2650.     ReadBinaryData(Name,MemStream.Memory^,DataSize);
  2651.     MemStream.Position := 0;
  2652.  
  2653.     Reader := TReader.Create(MemStream, 256);
  2654.     try
  2655.       Reader.Parent := Parent;
  2656.       Result := Reader.ReadRootComponent(nil);
  2657.       if Owner <> nil then
  2658.         try
  2659.           Owner.InsertComponent(Result);
  2660.         except
  2661.           Result.Free;
  2662.           raise;
  2663.         end;
  2664.     finally
  2665.       Reader.Free;
  2666.     end;
  2667.  
  2668.   finally
  2669.     MemStream.Free;
  2670.   end;
  2671. end;
  2672.  
  2673. procedure TPersistentRegistry.WriteComponent(const Name: String; Component: TComponent);
  2674. var
  2675.   MemStream: TMemoryStream;
  2676. begin
  2677.   MemStream := TMemoryStream.Create;
  2678.   try
  2679.     MemStream.WriteComponent(Component);
  2680.     WriteBinaryData(Name, MemStream.Memory^, MemStream.Size);
  2681.   finally
  2682.     MemStream.Free;
  2683.   end;
  2684. end;
  2685.  
  2686. {$ENDIF}
  2687.  
  2688. { TSystemMetric }
  2689.  
  2690. constructor TSystemMetric.Create;
  2691. begin
  2692.   inherited Create;
  2693.   Update;
  2694. end;
  2695.  
  2696. procedure TSystemMetric.Update;
  2697.  
  2698.   function GetSystemPoint(ax,ay: Integer):TPoint;
  2699.   begin
  2700.     Result:=Point(GetSystemMetrics(ax),GetSystemMetrics(ay));
  2701.   end;
  2702.  
  2703. begin
  2704.   FMenuHeight    :=GetSystemMetrics(SM_CYMENU);
  2705.   FCaptionHeight :=GetSystemMetrics(SM_CYCAPTION);
  2706.   FBorder        :=GetSystemPoint(SM_CXBORDER,SM_CYBORDER);
  2707.   FFrame         :=GetSystemPoint(SM_CXFRAME,SM_CYFRAME);
  2708.   FDlgFrame      :=GetSystemPoint(SM_CXDLGFRAME,SM_CYDLGFRAME);
  2709.   FBitmap        :=GetSystemPoint(SM_CXSIZE,SM_CYSIZE);
  2710.   FHScroll       :=GetSystemPoint(SM_CXHSCROLL,SM_CYHSCROLL);
  2711.   FVScroll       :=GetSystemPoint(SM_CXVSCROLL,SM_CYVSCROLL);
  2712.   FThumb         :=GetSystemPoint(SM_CXHTHUMB,SM_CYVTHUMB);
  2713.   FFullScreen    :=GetSystemPoint(SM_CXFULLSCREEN,SM_CYFULLSCREEN);
  2714.   FMin           :=GetSystemPoint(SM_CXMIN,SM_CYMIN);
  2715.   FMinTrack      :=GetSystemPoint(SM_CXMINTRACK,SM_CYMINTRACK);
  2716.   FCursor        :=GetSystemPoint(SM_CXCURSOR,SM_CYCURSOR);
  2717.   FIcon          :=GetSystemPoint(SM_CXICON,SM_CYICON);
  2718.   FDoubleClick   :=GetSystemPoint(SM_CXDOUBLECLK,SM_CYDOUBLECLK);
  2719.   FIconSpacing   :=GetSystemPoint(SM_CXICONSPACING,SM_CYICONSPACING);
  2720.   FColorDepth    :=sysColorDepth;
  2721. end;
  2722.  
  2723. { TDesktopCanvas }
  2724.  
  2725. constructor TDesktopCanvas.Create;
  2726. begin
  2727.   inherited Create;
  2728.   DC:=GetDC(0);
  2729.   Handle:=DC;
  2730. end;
  2731.  
  2732. destructor  TDesktopCanvas.Destroy;
  2733. begin
  2734.   Handle:=0;
  2735.   ReleaseDC(0, DC);
  2736.   inherited Destroy;
  2737. end;
  2738.  
  2739. {$IFNDEF Win32}
  2740.  
  2741. procedure DoneXProcs; far;
  2742. begin
  2743.   SysMetric.Free;
  2744. end;
  2745.  
  2746. {$ENDIF}
  2747.  
  2748. {$IFDEF Win32}
  2749. function CheckNT: Boolean;
  2750. var
  2751.   aVersion: TOSVersionInfo;
  2752. begin
  2753.   aVersion.dwOSVersionInfoSize:= SizeOf(aVersion);
  2754.   Result:= GetVersionEx(aVersion) and (aVersion.dwPLatformId = VER_PLATFORM_WIN32_NT);
  2755. end;
  2756. {$ENDIF}
  2757.  
  2758. initialization
  2759.   Randomize;
  2760.  
  2761.   SysMetric := TSystemMetric.Create;
  2762.   IsWin95   := (GetVersion and $FF00) >= $5F00;
  2763.  {$IFDEF Win32}
  2764.   IsWinNT   := CheckNT;
  2765.  {$ELSE}
  2766.   IsWinNT   := False;
  2767.  {$ENDIF}
  2768.  
  2769.   IsFabula  := nil;
  2770.  
  2771. {$IFDEF Win32}
  2772.   xLanguage := (LoWord(GetUserDefaultLangID) and $3ff);
  2773.   case xLanguage of
  2774.     LANG_GERMAN    : xLangOfs := 70000;
  2775.     LANG_ENGLISH   : xLangOfs := 71000;
  2776.     LANG_SPANISH   : xLangOfs := 72000;
  2777.     LANG_RUSSIAN   : xLangOfs := 73000;
  2778.     LANG_ITALIAN   : xLangOfs := 74000;
  2779.     LANG_FRENCH    : xLangOfs := 75000;
  2780.     LANG_PORTUGUESE: xLangOfs := 76000;
  2781.     else             xLangOfs := 71000;
  2782.   end;
  2783. {$ENDIF}
  2784.  
  2785. {$IFDEF Win32}
  2786. finalization
  2787.   SysMetric.Free;
  2788. {$ELSE}
  2789.   AddExitProc(DoneXProcs);
  2790. {$ENDIF}
  2791. end.
  2792.